scm/define-markup-commands.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2012  Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;                  Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;
  20 ;;; Markup commands and markup-list commands definitions.
  21 ;;;
  22 ;;; Markup commands which are part of LilyPond, are defined
  23 ;;; in the (lily) module, which is the current module in this file,
  24 ;;; using the `define-markup-command' macro.
  25 ;;;
  26 ;;; Usage:
  27 ;;;
  28 ;;; (define-markup-command (command-name layout props args...)
  29 ;;;   args-signature
  30 ;;;   [ #:category category ]
  31 ;;;   [ #:properties property-bindings ]
  32 ;;;   documentation-string
  33 ;;;   ..body..)
  34 ;;;
  35 ;;; with:
  36 ;;;   command-name
  37 ;;;     the name of the markup command
  38 ;;;
  39 ;;;   layout and props
  40 ;;;     arguments that are automatically passed to the command when it
  41 ;;;     is interpreted.
  42 ;;;     `layout' is an output def, which properties can be accessed
  43 ;;;     using `ly:output-def-lookup'.
  44 ;;;     `props' is a list of property settings which can be accessed
  45 ;;;     using `chain-assoc-get' (more on that below)
  46 ;;;
  47 ;;;   args...
  48 ;;;     the command arguments.
  49 ;;;     There is no limitation on the order of command arguments.
  50 ;;;     However, markup functions taking a markup as their last
  51 ;;;     argument are somewhat special as you can apply them to a
  52 ;;;     markup list, and the result is a markup list where the
  53 ;;;     markup function (with the specified leading arguments) has
  54 ;;;     been applied to every element of the original markup list.
  55 ;;;
  56 ;;;     Since replicating the leading arguments for applying a
  57 ;;;     markup function to a markup list is cheap mostly for
  58 ;;;     Scheme arguments, you avoid performance pitfalls by just
  59 ;;;     using Scheme arguments for the leading arguments of markup
  60 ;;;     functions that take a markup as their last argument.
  61 ;;;
  62 ;;;   args-signature
  63 ;;;     the arguments signature, i.e., a list of type predicates which
  64 ;;;     are used to type check the arguments, and also to define the general
  65 ;;;     argument types (markup, markup-list, scheme) that the command is
  66 ;;;     expecting.
  67 ;;;     For instance, if a command expects a number, then a markup, the
  68 ;;;     signature would be: (number? markup?)
  69 ;;;
  70 ;;;   category
  71 ;;;     for documentation purpose, builtin markup commands are grouped by
  72 ;;;     category.  This can be any symbol.  When documentation is generated,
  73 ;;;     the symbol is converted to a capitalized string, where hyphens are
  74 ;;;     replaced by spaces.
  75 ;;;
  76 ;;;   property-bindings
  77 ;;;     this is used both for documentation generation, and to ease
  78 ;;;     programming the command itself.  It is list of
  79 ;;;        (property-name default-value)
  80 ;;;     or (property-name)
  81 ;;;     elements.  Each property is looked-up in the `props' argument, and
  82 ;;;     the symbol naming the property is bound to its value.
  83 ;;;     When the property is not found in `props', then the symbol is bound
  84 ;;;     to the given default value.  When no default value is given, #f is
  85 ;;;     used instead.
  86 ;;;     Thus, using the following property bindings:
  87 ;;;       ((thickness 0.1)
  88 ;;;        (font-size 0))
  89 ;;;     is equivalent to writing:
  90 ;;;       (let ((thickness (chain-assoc-get 'thickness props 0.1))
  91 ;;;             (font-size (chain-assoc-get 'font-size props 0)))
  92 ;;;         ..body..)
  93 ;;;     When a command `B' internally calls an other command `A', it may
  94 ;;;     desirable to see in `B' documentation all the properties and
  95 ;;;     default values used by `A'.  In that case, add `A-markup' to the
  96 ;;;     property-bindings of B.  (This is used when generating
  97 ;;;     documentation, but won't create bindings.)
  98 ;;;
  99 ;;;   documentation-string
 100 ;;;     the command documentation string (used to generate manuals)
 101 ;;;
 102 ;;;   body
 103 ;;;     the command body.  The function is supposed to return a stencil.
 104 ;;;
 105 ;;; Each markup command definition shall have a documentation string
 106 ;;; with description, syntax and example.
 107
 108 (use-modules (ice-9 regex))
 109
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;; utility functions
 112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113
 114 (define-public empty-stencil (ly:make-stencil '()
 115                                               empty-interval empty-interval))
 116 (define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 117
 118 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 119 ;; geometric shapes
 120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 121
 122 (define-markup-command (draw-line layout props dest)
 123   (number-pair?)
 124   #:category graphic
 125   #:properties ((thickness 1))
 126   "
 127 @cindex drawing lines within text
 128
 129 A simple line.
 130 @lilypond[verbatim,quote]
 131 \\markup {
 132   \\draw-line #'(4 . 4)
 133   \\override #'(thickness . 5)
 134   \\draw-line #'(-3 . 0)
 135 }
 136 @end lilypond"
 137   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 138                thickness))
 139         (x (car dest))
 140         (y (cdr dest)))
 141     (make-line-stencil th 0 0 x y)))
 142
 143 (define-markup-command (draw-dashed-line layout props dest)
 144   (number-pair?)
 145   #:category graphic
 146   #:properties ((thickness 1)
 147                 (on 1)
 148                 (off 1)
 149                 (phase 0)
 150                 (full-length #t))
 151   "
 152 @cindex drawing dashed lines within text
 153
 154 A dashed line.
 155
 156 If @code{full-length} is set to #t (default) the dashed-line extends to the
 157 whole length given by @var{dest}, without white space at beginning or end.
 158 @code{off} will then be altered to fit.
 159 To insist on the given (or default) values of @code{on}, @code{off} use
 160 @code{\\override #'(full-length . #f)}
 161 Manual settings for @code{on},@code{off} and @code{phase} are possible.
 162 @lilypond[verbatim,quote]
 163 \\markup {
 164   \\draw-dashed-line #'(5.1 . 2.3)
 165   \\override #'(on . 0.3)
 166   \\override #'(off . 0.5)
 167   \\draw-dashed-line #'(5.1 . 2.3)
 168 }
 169 @end lilypond"
 170   (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness))
 171          ;; Calculate the thickness to be used.
 172          (th (* line-thickness thickness))
 173          (half-thick (/ th 2))
 174          ;; Get the extensions in x- and y-direction.
 175          (x (car dest))
 176          (y (cdr dest))
 177          ;; Calculate the length of the dashed line.
 178          (line-length (sqrt (+ (expt x 2) (expt y 2)))))
 179
 180     (if (and full-length (not (= (+ on off) 0)))
 181         (begin
 182           ;; Add double-thickness to avoid overlapping.
 183           (set! off (+ (* 2 th) off))
 184           (let* (;; Make a guess how often the off/on-pair should be printed
 185                  ;; after the initial `on´.
 186                  ;; Assume a minimum of 1 to avoid division by zero.
 187                  (guess (max 1 (round (/ (- line-length on) (+ off on)))))
 188                  ;; Not sure about the value or why corr is necessary at all,
 189                  ;; but it seems to be necessary.
 190                  (corr (if (= on 0)
 191                            (/ line-thickness 10)
 192                            0))
 193                  ;; Calculate a new value for off to fit the
 194                  ;; line-length.
 195                  (new-off (/ (- line-length corr (* (1+ guess) on)) guess))
 196                  )
 197             (cond
 198
 199              ;; Settings for (= on 0). Resulting in a dotted line.
 200
 201              ;; If line-length isn't shorter than `th´, change the given
 202              ;; value for `off´ to fit the line-length.
 203              ((and (= on 0) (< th line-length))
 204               (set! off new-off))
 205
 206              ;; If the line-length is shorter than `th´, it makes no
 207              ;; sense to adjust `off´. The rounded edges of the lines
 208              ;; would prevent any nice output.
 209              ;; Do nothing.
 210              ;; This will result in a single dot for very short lines.
 211              ((and (= on 0) (>= th line-length))
 212               #f)
 213
 214              ;; Settings for (not (= on 0)). Resulting in a dashed line.
 215
 216              ;; If line-length isn't shorter than one go of on-off-on,
 217              ;; change the given value for `off´ to fit the line-length.
 218              ((< (+ (* 2 on) off) line-length)
 219               (set! off new-off))
 220              ;; If the line-length is too short, but greater than
 221              ;; (* 4 th) set on/off to (/ line-length 3)
 222              ((< (* 4 th) line-length)
 223               (set! on (/ line-length 3))
 224               (set! off (/ line-length 3)))
 225              ;; If the line-length is shorter than (* 4 th), it makes
 226              ;; no sense trying to adjust on/off. The rounded edges of
 227              ;; the lines would prevent any nice output.
 228              ;; Simply set `on´ to line-length.
 229              (else
 230               (set! on line-length))))))
 231
 232     ;; If `on´ or `off´ is negative, or the sum of `on' and `off' equals zero a
 233     ;; ghostscript-error occurs while calling
 234     ;; (ly:make-stencil (list 'dashed-line th on off x y phase) x-ext y-ext)
 235     ;; Better be paranoid.
 236     (if (or (= (+ on off) 0)
 237             (negative? on)
 238             (negative? off))
 239         (begin
 240           (ly:warning "Can't print a line - setting on/off to default")
 241           (set! on 1)
 242           (set! off 1)))
 243
 244     ;; To give the lines produced by \draw-line and \draw-dashed-line the same
 245     ;; length, half-thick has to be added to the stencil-extensions.
 246     (ly:make-stencil
 247      (list 'dashed-line th on off x y phase)
 248      (interval-widen (ordered-cons 0 x) half-thick)
 249      (interval-widen (ordered-cons 0 y) half-thick))))
 250
 251 (define-markup-command (draw-dotted-line layout props dest)
 252   (number-pair?)
 253   #:category graphic
 254   #:properties ((thickness 1)
 255                 (off 1)
 256                 (phase 0))
 257   "
 258 @cindex drawing dotted lines within text
 259
 260 A dotted line.
 261
 262 The dotted-line always extends to the whole length given by @var{dest}, without
 263 white space at beginning or end.
 264 Manual settings for @code{off} are possible to get larger or smaller space
 265 between the dots.
 266 The given (or default) value of @code{off} will be altered to fit the
 267 line-length.
 268 @lilypond[verbatim,quote]
 269 \\markup {
 270   \\draw-dotted-line #'(5.1 . 2.3)
 271   \\override #'(thickness . 2)
 272   \\override #'(off . 0.2)
 273   \\draw-dotted-line #'(5.1 . 2.3)
 274 }
 275 @end lilypond"
 276
 277   (let ((new-props (prepend-alist-chain 'on 0
 278                                         (prepend-alist-chain 'full-length #t props))))
 279
 280     (interpret-markup layout
 281                       new-props
 282                       (markup #:draw-dashed-line dest))))
 283
 284 (define-markup-command (draw-hline layout props)
 285   ()
 286   #:category graphic
 287   #:properties ((draw-line-markup)
 288                 (line-width)
 289                 (span-factor 1))
 290   "
 291 @cindex drawing a line across a page
 292
 293 Draws a line across a page, where the property @code{span-factor}
 294 controls what fraction of the page is taken up.
 295 @lilypond[verbatim,quote]
 296 \\markup {
 297   \\column {
 298     \\draw-hline
 299     \\override #'(span-factor . 1/3)
 300     \\draw-hline
 301   }
 302 }
 303 @end lilypond"
 304   (interpret-markup layout
 305                     props
 306                     (markup #:draw-line (cons (* line-width
 307                                                  span-factor)
 308                                               0))))
 309
 310 (define-markup-command (draw-circle layout props radius thickness filled)
 311   (number? number? boolean?)
 312   #:category graphic
 313   "
 314 @cindex drawing circles within text
 315
 316 A circle of radius @var{radius} and thickness @var{thickness},
 317 optionally filled.
 318
 319 @lilypond[verbatim,quote]
 320 \\markup {
 321   \\draw-circle #2 #0.5 ##f
 322   \\hspace #2
 323   \\draw-circle #2 #0 ##t
 324 }
 325 @end lilypond"
 326   (make-circle-stencil radius thickness filled))
 327
 328 (define-markup-command (triangle layout props filled)
 329   (boolean?)
 330   #:category graphic
 331   #:properties ((thickness 0.1)
 332                 (font-size 0)
 333                 (baseline-skip 2))
 334   "
 335 @cindex drawing triangles within text
 336
 337 A triangle, either filled or empty.
 338
 339 @lilypond[verbatim,quote]
 340 \\markup {
 341   \\triangle ##t
 342   \\hspace #2
 343   \\triangle ##f
 344 }
 345 @end lilypond"
 346   (let ((ex (* (magstep font-size) 0.8 baseline-skip)))
 347     (ly:make-stencil
 348      `(polygon '(0.0 0.0
 349                      ,ex 0.0
 350                      ,(* 0.5 ex)
 351                      ,(* 0.86 ex))
 352                ,thickness
 353                ,filled)
 354      (cons 0 ex)
 355      (cons 0 (* .86 ex)))))
 356
 357 (define-markup-command (circle layout props arg)
 358   (markup?)
 359   #:category graphic
 360   #:properties ((thickness 1)
 361                 (font-size 0)
 362                 (circle-padding 0.2))
 363   "
 364 @cindex circling text
 365
 366 Draw a circle around @var{arg}.  Use @code{thickness},
 367 @code{circle-padding} and @code{font-size} properties to determine line
 368 thickness and padding around the markup.
 369
 370 @lilypond[verbatim,quote]
 371 \\markup {
 372   \\circle {
 373     Hi
 374   }
 375 }
 376 @end lilypond"
 377   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 378                thickness))
 379         (pad (* (magstep font-size) circle-padding))
 380         (m (interpret-markup layout props arg)))
 381     (circle-stencil m th pad)))
 382
 383 (define-markup-command (ellipse layout props arg)
 384   (markup?)
 385   #:category graphic
 386   #:properties ((thickness 1)
 387                 (font-size 0)
 388                 (x-padding 0.2)
 389                 (y-padding 0.2))
 390   "
 391 @cindex drawing ellipse around text
 392
 393 Draw an ellipse around @var{arg}.  Use @code{thickness},
 394 @code{x-padding}, @code{y-padding} and @code{font-size} properties to determine
 395 line thickness and padding around the markup.
 396
 397 @lilypond[verbatim,quote]
 398 \\markup {
 399   \\ellipse {
 400     Hi
 401   }
 402 }
 403 @end lilypond"
 404   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 405                thickness))
 406         (pad-x (* (magstep font-size) x-padding))
 407         (pad-y (* (magstep font-size) y-padding))
 408         (m (interpret-markup layout props arg)))
 409     (ellipse-stencil m th pad-x pad-y)))
 410
 411 (define-markup-command (oval layout props arg)
 412   (markup?)
 413   #:category graphic
 414   #:properties ((thickness 1)
 415                 (font-size 0)
 416                 (x-padding 0.75)
 417                 (y-padding 0.75))
 418   "
 419 @cindex drawing oval around text
 420
 421 Draw an oval around @var{arg}.  Use @code{thickness},
 422 @code{x-padding}, @code{x-padding} and @code{font-size} properties to determine
 423 line thickness and padding around the markup.
 424
 425 @lilypond[verbatim,quote]
 426 \\markup {
 427   \\oval {
 428     Hi
 429   }
 430 }
 431 @end lilypond"
 432   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 433                thickness))
 434         (pad-x (* (magstep font-size) x-padding))
 435         (pad-y (* (magstep font-size) y-padding))
 436         (m (interpret-markup layout props arg)))
 437     (oval-stencil m th pad-x pad-y)))
 438
 439 (define-markup-command (with-url layout props url arg)
 440   (string? markup?)
 441   #:category graphic
 442   "
 443 @cindex inserting URL links into text
 444
 445 Add a link to URL @var{url} around @var{arg}.  This only works in
 446 the PDF backend.
 447
 448 @lilypond[verbatim,quote]
 449 \\markup {
 450   \\with-url #\"http://lilypond.org/\" {
 451     LilyPond ... \\italic {
 452       music notation for everyone
 453     }
 454   }
 455 }
 456 @end lilypond"
 457   (let* ((stil (interpret-markup layout props arg))
 458          (xextent (ly:stencil-extent stil X))
 459          (yextent (ly:stencil-extent stil Y))
 460          (old-expr (ly:stencil-expr stil))
 461          (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
 462
 463     (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
 464
 465 (define-markup-command (page-link layout props page-number arg)
 466   (number? markup?)
 467   #:category other
 468   "
 469 @cindex referencing page numbers in text
 470
 471 Add a link to the page @var{page-number} around @var{arg}.  This only works
 472 in the PDF backend.
 473
 474 @lilypond[verbatim,quote]
 475 \\markup {
 476   \\page-link #2  { \\italic { This links to page 2... } }
 477 }
 478 @end lilypond"
 479   (let* ((stil (interpret-markup layout props arg))
 480          (xextent (ly:stencil-extent stil X))
 481          (yextent (ly:stencil-extent stil Y))
 482          (old-expr (ly:stencil-expr stil))
 483          (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent))))
 484
 485     (ly:stencil-add (ly:make-stencil link-expr xextent yextent) stil)))
 486
 487 (define-markup-command (with-link layout props label arg)
 488   (symbol? markup?)
 489   #:category other
 490   "
 491 @cindex referencing page labels in text
 492
 493 Add a link to the page holding label @var{label} around @var{arg}.  This
 494 only works in the PDF backend.
 495
 496 @lilypond[verbatim,quote]
 497 \\markup {
 498   \\with-link #'label {
 499     \\italic { This links to the page containing the label... }
 500   }
 501 }
 502 @end lilypond"
 503   (let* ((arg-stencil (interpret-markup layout props arg))
 504          (x-ext (ly:stencil-extent arg-stencil X))
 505          (y-ext (ly:stencil-extent arg-stencil Y)))
 506     (ly:stencil-add
 507      (ly:make-stencil
 508       `(delay-stencil-evaluation
 509         ,(delay (let* ((table (ly:output-def-lookup layout 'label-page-table))
 510                        (page-number (if (list? table)
 511                                         (assoc-get label table)
 512                                         #f)))
 513                   (list 'page-link page-number
 514                         `(quote ,x-ext) `(quote ,y-ext)))))
 515       x-ext
 516       y-ext)
 517      arg-stencil)))
 518
 519
 520 (define-markup-command (beam layout props width slope thickness)
 521   (number? number? number?)
 522   #:category graphic
 523   "
 524 @cindex drawing beams within text
 525
 526 Create a beam with the specified parameters.
 527 @lilypond[verbatim,quote]
 528 \\markup {
 529   \\beam #5 #1 #2
 530 }
 531 @end lilypond"
 532   (let* ((y (* slope width))
 533          (yext (cons (min 0 y) (max 0 y)))
 534          (half (/ thickness 2)))
 535
 536     (ly:make-stencil
 537      `(polygon ',(list
 538                   0 (/ thickness -2)
 539                   width (+ (* width slope)  (/ thickness -2))
 540                   width (+ (* width slope)  (/ thickness 2))
 541                   0 (/ thickness 2))
 542                ,(ly:output-def-lookup layout 'blot-diameter)
 543                #t)
 544      (cons 0 width)
 545      (cons (+ (- half) (car yext))
 546            (+ half (cdr yext))))))
 547
 548 (define-markup-command (underline layout props arg)
 549   (markup?)
 550   #:category font
 551   #:properties ((thickness 1) (offset 2))
 552   "
 553 @cindex underlining text
 554
 555 Underline @var{arg}.  Looks at @code{thickness} to determine line
 556 thickness, and @code{offset} to determine line y-offset.
 557
 558 @lilypond[verbatim,quote]
 559 \\markup \\fill-line {
 560   \\underline \"underlined\"
 561   \\override #'(offset . 5)
 562   \\override #'(thickness . 1)
 563   \\underline \"underlined\"
 564   \\override #'(offset . 1)
 565   \\override #'(thickness . 5)
 566   \\underline \"underlined\"
 567 }
 568 @end lilypond"
 569   (let* ((thick (ly:output-def-lookup layout 'line-thickness))
 570          (underline-thick (* thickness thick))
 571          (markup (interpret-markup layout props arg))
 572          (x1 (car (ly:stencil-extent markup X)))
 573          (x2 (cdr (ly:stencil-extent markup X)))
 574          (y (* thick (- offset)))
 575          (line (make-line-stencil underline-thick x1 y x2 y)))
 576     (ly:stencil-add markup line)))
 577
 578 (define-markup-command (box layout props arg)
 579   (markup?)
 580   #:category font
 581   #:properties ((thickness 1)
 582                 (font-size 0)
 583                 (box-padding 0.2))
 584   "
 585 @cindex enclosing text within a box
 586
 587 Draw a box round @var{arg}.  Looks at @code{thickness},
 588 @code{box-padding} and @code{font-size} properties to determine line
 589 thickness and padding around the markup.
 590
 591 @lilypond[verbatim,quote]
 592 \\markup {
 593   \\override #'(box-padding . 0.5)
 594   \\box
 595   \\line { V. S. }
 596 }
 597 @end lilypond"
 598   (let* ((th (* (ly:output-def-lookup layout 'line-thickness)
 599                 thickness))
 600          (pad (* (magstep font-size) box-padding))
 601          (m (interpret-markup layout props arg)))
 602     (box-stencil m th pad)))
 603
 604 (define-markup-command (filled-box layout props xext yext blot)
 605   (number-pair? number-pair? number?)
 606   #:category graphic
 607   "
 608 @cindex drawing solid boxes within text
 609 @cindex drawing boxes with rounded corners
 610
 611 Draw a box with rounded corners of dimensions @var{xext} and
 612 @var{yext}.  For example,
 613 @verbatim
 614 \\filled-box #'(-.3 . 1.8) #'(-.3 . 1.8) #0
 615 @end verbatim
 616 creates a box extending horizontally from -0.3 to 1.8 and
 617 vertically from -0.3 up to 1.8, with corners formed from a
 618 circle of diameter@tie{}0 (i.e., sharp corners).
 619
 620 @lilypond[verbatim,quote]
 621 \\markup {
 622   \\filled-box #'(0 . 4) #'(0 . 4) #0
 623   \\filled-box #'(0 . 2) #'(-4 . 2) #0.4
 624   \\filled-box #'(1 . 8) #'(0 . 7) #0.2
 625   \\with-color #white
 626   \\filled-box #'(-4.5 . -2.5) #'(3.5 . 5.5) #0.7
 627 }
 628 @end lilypond"
 629   (ly:round-filled-box
 630    xext yext blot))
 631
 632 (define-markup-command (rounded-box layout props arg)
 633   (markup?)
 634   #:category graphic
 635   #:properties ((thickness 1)
 636                 (corner-radius 1)
 637                 (font-size 0)
 638                 (box-padding 0.5))
 639   "@cindex enclosing text in a box with rounded corners
 640    @cindex drawing boxes with rounded corners around text
 641 Draw a box with rounded corners around @var{arg}.  Looks at @code{thickness},
 642 @code{box-padding} and @code{font-size} properties to determine line
 643 thickness and padding around the markup; the @code{corner-radius} property
 644 makes it possible to define another shape for the corners (default is 1).
 645
 646 @lilypond[quote,verbatim,relative=2]
 647 c4^\\markup {
 648   \\rounded-box {
 649     Overtura
 650   }
 651 }
 652 c,8. c16 c4 r
 653 @end lilypond"
 654   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 655                thickness))
 656         (pad (* (magstep font-size) box-padding))
 657         (m (interpret-markup layout props arg)))
 658     (ly:stencil-add (rounded-box-stencil m th pad corner-radius)
 659                     m)))
 660
 661 (define-markup-command (rotate layout props ang arg)
 662   (number? markup?)
 663   #:category align
 664   "
 665 @cindex rotating text
 666
 667 Rotate object with @var{ang} degrees around its center.
 668
 669 @lilypond[verbatim,quote]
 670 \\markup {
 671   default
 672   \\hspace #2
 673   \\rotate #45
 674   \\line {
 675     rotated 45°
 676   }
 677 }
 678 @end lilypond"
 679   (let* ((stil (interpret-markup layout props arg)))
 680     (ly:stencil-rotate stil ang 0 0)))
 681
 682 (define-markup-command (whiteout layout props arg)
 683   (markup?)
 684   #:category other
 685   "
 686 @cindex adding a white background to text
 687
 688 Provide a white background for @var{arg}.
 689
 690 @lilypond[verbatim,quote]
 691 \\markup {
 692   \\combine
 693     \\filled-box #'(-1 . 10) #'(-3 . 4) #1
 694     \\whiteout whiteout
 695 }
 696 @end lilypond"
 697   (stencil-whiteout (interpret-markup layout props arg)))
 698
 699 (define-markup-command (pad-markup layout props amount arg)
 700   (number? markup?)
 701   #:category align
 702   "
 703 @cindex padding text
 704 @cindex putting space around text
 705
 706 Add space around a markup object.
 707 Identical to @code{pad-around}.
 708
 709 @lilypond[verbatim,quote]
 710 \\markup {
 711   \\box {
 712     default
 713   }
 714   \\hspace #2
 715   \\box {
 716     \\pad-markup #1 {
 717       padded
 718     }
 719   }
 720 }
 721 @end lilypond"
 722   (let* ((m (interpret-markup layout props arg))
 723          (x (interval-widen (ly:stencil-extent m X) amount))
 724          (y (interval-widen (ly:stencil-extent m Y) amount)))
 725     (ly:stencil-add (make-transparent-box-stencil x y)
 726                     m)))
 727
 728 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 729 ;; space
 730 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 731
 732 (define-markup-command (strut layout props)
 733   ()
 734   #:category other
 735   "
 736 @cindex creating vertical spaces in text
 737
 738 Create a box of the same height as the space in the current font."
 739   (let ((m (ly:text-interface::interpret-markup layout props " ")))
 740     (ly:make-stencil (ly:stencil-expr m)
 741                      '(0 . 0)
 742                      (ly:stencil-extent m X)
 743                      )))
 744
 745 (define-markup-command (hspace layout props amount)
 746   (number?)
 747   #:category align
 748   "
 749 @cindex creating horizontal spaces in text
 750
 751 Create an invisible object taking up horizontal space @var{amount}.
 752
 753 @lilypond[verbatim,quote]
 754 \\markup {
 755   one
 756   \\hspace #2
 757   two
 758   \\hspace #8
 759   three
 760 }
 761 @end lilypond"
 762   (ly:make-stencil "" (cons 0 amount) empty-interval))
 763
 764 (define-markup-command (vspace layout props amount)
 765   (number?)
 766   #:category align
 767   "
 768 @cindex creating vertical spaces in text
 769
 770 Create an invisible object taking up vertical space
 771 of @var{amount} multiplied by 3.
 772
 773 @lilypond[verbatim,quote]
 774 \\markup {
 775     \\center-column {
 776     one
 777     \\vspace #2
 778     two
 779     \\vspace #5
 780     three
 781   }
 782 }
 783 @end lilypond"
 784   (let ((amount (* amount 3.0)))
 785     (ly:make-stencil "" empty-interval (cons 0 amount))))
 786
 787
 788 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 789 ;; importing graphics.
 790 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 791
 792 (define-markup-command (stencil layout props stil)
 793   (ly:stencil?)
 794   #:category other
 795   "
 796 @cindex importing stencils into text
 797
 798 Use a stencil as markup.
 799
 800 @lilypond[verbatim,quote]
 801 \\markup {
 802   \\stencil #(make-circle-stencil 2 0 #t)
 803 }
 804 @end lilypond"
 805   stil)
 806
 807 (define bbox-regexp
 808   (make-regexp "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))
 809
 810 (define (get-postscript-bbox string)
 811   "Extract the bbox from STRING, or return #f if not present."
 812   (let*
 813       ((match (regexp-exec bbox-regexp string)))
 814
 815     (if match
 816         (map (lambda (x)
 817                (string->number (match:substring match x)))
 818              (cdr (iota 5)))
 819
 820         #f)))
 821
 822 (define-markup-command (epsfile layout props axis size file-name)
 823   (number? number? string?)
 824   #:category graphic
 825   "
 826 @cindex inlining an Encapsulated PostScript image
 827
 828 Inline an EPS image.  The image is scaled along @var{axis} to
 829 @var{size}.
 830
 831 @lilypond[verbatim,quote]
 832 \\markup {
 833   \\general-align #Y #DOWN {
 834     \\epsfile #X #20 #\"context-example.eps\"
 835     \\epsfile #Y #20 #\"context-example.eps\"
 836   }
 837 }
 838 @end lilypond"
 839   (if (ly:get-option 'safe)
 840       (interpret-markup layout props "not allowed in safe")
 841       (eps-file->stencil axis size file-name)
 842       ))
 843
 844 (define-markup-command (postscript layout props str)
 845   (string?)
 846   #:category graphic
 847   "
 848 @cindex inserting PostScript directly into text
 849 This inserts @var{str} directly into the output as a PostScript
 850 command string.
 851
 852 @lilypond[verbatim,quote]
 853 ringsps = #\"
 854   0.15 setlinewidth
 855   0.9 0.6 moveto
 856   0.4 0.6 0.5 0 361 arc
 857   stroke
 858   1.0 0.6 0.5 0 361 arc
 859   stroke
 860   \"
 861
 862 rings = \\markup {
 863   \\with-dimensions #'(-0.2 . 1.6) #'(0 . 1.2)
 864   \\postscript #ringsps
 865 }
 866
 867 \\relative c'' {
 868   c2^\\rings
 869   a2_\\rings
 870 }
 871 @end lilypond"
 872   ;; FIXME
 873   (ly:make-stencil
 874    (list 'embedded-ps
 875          (format #f "
 876 gsave currentpoint translate
 877 0.1 setlinewidth
 878  ~a
 879 grestore
 880 "
 881                  str))
 882    '(0 . 0) '(0 . 0)))
 883
 884 (define-markup-command (path layout props thickness commands) (number? list?)
 885   #:category graphic
 886   #:properties ((line-cap-style 'round)
 887                 (line-join-style 'round)
 888                 (filled #f))
 889   "
 890 @cindex paths, drawing
 891 @cindex drawing paths
 892 Draws a path with line @var{thickness} according to the
 893 directions given in @var{commands}.  @var{commands} is a list of
 894 lists where the @code{car} of each sublist is a drawing command and
 895 the @code{cdr} comprises the associated arguments for each command.
 896
 897 There are seven commands available to use in the list
 898 @code{commands}: @code{moveto}, @code{rmoveto}, @code{lineto},
 899 @code{rlineto}, @code{curveto}, @code{rcurveto}, and
 900 @code{closepath}.  Note that the commands that begin with @emph{r}
 901 are the relative variants of the other three commands.
 902
 903 The commands @code{moveto}, @code{rmoveto}, @code{lineto}, and
 904 @code{rlineto} take 2 arguments; they are the X and Y coordinates
 905 for the destination point.
 906
 907 The commands @code{curveto} and @code{rcurveto} create cubic
 908 Bézier curves, and take 6 arguments; the first two are the X and Y
 909 coordinates for the first control point, the second two are the X
 910 and Y coordinates for the second control point, and the last two
 911 are the X and Y coordinates for the destination point.
 912
 913 The @code{closepath} command takes zero arguments and closes the
 914 current subpath in the active path.
 915
 916 Note that a sequence of commands @emph{must} begin with a
 917 @code{moveto} or @code{rmoveto} to work with the SVG output.
 918
 919 Line-cap styles and line-join styles may be customized by
 920 overriding the @code{line-cap-style} and @code{line-join-style}
 921 properties, respectively.  Available line-cap styles are
 922 @code{'butt}, @code{'round}, and @code{'square}.  Available
 923 line-join styles are @code{'miter}, @code{'round}, and
 924 @code{'bevel}.
 925
 926 The property @code{filled} specifies whether or not the path is
 927 filled with color.
 928
 929 @lilypond[verbatim,quote]
 930 samplePath =
 931   #'((moveto 0 0)
 932      (lineto -1 1)
 933      (lineto 1 1)
 934      (lineto 1 -1)
 935      (curveto -5 -5 -5 5 -1 0)
 936      (closepath))
 937
 938 \\markup {
 939   \\path #0.25 #samplePath
 940
 941   \\override #'(line-join-style . miter) \\path #0.25 #samplePath
 942
 943   \\override #'(filled . #t) \\path #0.25 #samplePath
 944 }
 945 @end lilypond"
 946   (let* ((half-thickness (/ thickness 2))
 947          (current-point '(0 . 0))
 948          (set-point (lambda (lst) (set! current-point lst)))
 949          (relative? (lambda (x)
 950                       (string-prefix? "r" (symbol->string (car x)))))
 951          ;; For calculating extents, we want to modify the command
 952          ;; list so that all coordinates are absolute.
 953          (new-commands (map (lambda (x)
 954                               (cond
 955                                ;; for rmoveto, rlineto
 956                                ((and (relative? x) (= 3 (length x)))
 957                                 (let ((cp (cons
 958                                            (+ (car current-point)
 959                                               (second x))
 960                                            (+ (cdr current-point)
 961                                               (third x)))))
 962                                   (set-point cp)
 963                                   (list (car cp)
 964                                         (cdr cp))))
 965                                ;; for rcurveto
 966                                ((and (relative? x) (= 7 (length x)))
 967                                 (let* ((old-cp current-point)
 968                                        (cp (cons
 969                                             (+ (car old-cp)
 970                                                (sixth x))
 971                                             (+ (cdr old-cp)
 972                                                (seventh x)))))
 973                                   (set-point cp)
 974                                   (list (+ (car old-cp) (second x))
 975                                         (+ (cdr old-cp) (third x))
 976                                         (+ (car old-cp) (fourth x))
 977                                         (+ (cdr old-cp) (fifth x))
 978                                         (car cp)
 979                                         (cdr cp))))
 980                                ;; for moveto, lineto
 981                                ((= 3 (length x))
 982                                 (set-point (cons (second x)
 983                                                  (third x)))
 984                                 (drop x 1))
 985                                ;; for curveto
 986                                ((= 7 (length x))
 987                                 (set-point (cons (sixth x)
 988                                                  (seventh x)))
 989                                 (drop x 1))
 990                                ;; keep closepath for filtering;
 991                                ;; see `without-closepath'.
 992                                (else x)))
 993                             commands))
 994          ;; path-min-max does not accept 0-arg lists,
 995          ;; and since closepath does not affect extents, filter
 996          ;; out those commands here.
 997          (without-closepath (filter (lambda (x)
 998                                       (not (equal? 'closepath (car x))))
 999                                     new-commands))
1000          (extents (path-min-max
1001                    ;; set the origin to the first moveto
1002                    (list (list-ref (car without-closepath) 0)
1003                          (list-ref (car without-closepath) 1))
1004                    without-closepath))
1005          (X-extent (cons (list-ref extents 0) (list-ref extents 1)))
1006          (Y-extent (cons (list-ref extents 2) (list-ref extents 3)))
1007          (command-list (fold-right append '() commands)))
1008
1009     ;; account for line thickness
1010     (set! X-extent (interval-widen X-extent half-thickness))
1011     (set! Y-extent (interval-widen Y-extent half-thickness))
1012
1013     (ly:make-stencil
1014      `(path ,thickness `(,@',command-list)
1015             ',line-cap-style ',line-join-style ,filled)
1016      X-extent
1017      Y-extent)))
1018
1019 (define-markup-command (score layout props score)
1020   (ly:score?)
1021   #:category music
1022   #:properties ((baseline-skip))
1023   "
1024 @cindex inserting music into text
1025
1026 Inline an image of music.  The reference point (usually the middle
1027 staff line) of the lowest staff in the top system is placed on the
1028 baseline.
1029
1030 @lilypond[verbatim,quote]
1031 \\markup {
1032   \\score {
1033     \\new PianoStaff <<
1034       \\new Staff \\relative c' {
1035         \\key f \\major
1036         \\time 3/4
1037         \\mark \\markup { Allegro }
1038         f2\\p( a4)
1039         c2( a4)
1040         bes2( g'4)
1041         f8( e) e4 r
1042       }
1043       \\new Staff \\relative c {
1044         \\clef bass
1045         \\key f \\major
1046         \\time 3/4
1047         f8( a c a c a
1048         f c' es c es c)
1049         f,( bes d bes d bes)
1050         f( g bes g bes g)
1051       }
1052     >>
1053     \\layout {
1054       indent = 0.0\\cm
1055       \\context {
1056         \\Score
1057         \\override RehearsalMark
1058           #'break-align-symbols = #'(time-signature key-signature)
1059         \\override RehearsalMark
1060           #'self-alignment-X = #LEFT
1061       }
1062       \\context {
1063         \\Staff
1064         \\override TimeSignature
1065           #'break-align-anchor-alignment = #LEFT
1066       }
1067     }
1068   }
1069 }
1070 @end lilypond"
1071   (let ((output (ly:score-embedded-format score layout)))
1072
1073     (if (ly:music-output? output)
1074         (let ((paper-systems
1075                (vector->list
1076                 (ly:paper-score-paper-systems output))))
1077           (if (pair? paper-systems)
1078               ;; shift such that the refpoint of the bottom staff of
1079               ;; the first system is the baseline of the score
1080               (ly:stencil-translate-axis
1081                (stack-stencils Y DOWN baseline-skip
1082                                (map paper-system-stencil paper-systems))
1083                (- (car (paper-system-staff-extents (car paper-systems))))
1084                Y)
1085               empty-stencil))
1086         (begin
1087           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
1088           empty-stencil))))
1089
1090 (define-markup-command (null layout props)
1091   ()
1092   #:category other
1093   "
1094 @cindex creating empty text objects
1095
1096 An empty markup with extents of a single point.
1097
1098 @lilypond[verbatim,quote]
1099 \\markup {
1100   \\null
1101 }
1102 @end lilypond"
1103   point-stencil)
1104
1105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1106 ;; basic formatting.
1107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1108
1109 (define-markup-command (simple layout props str)
1110   (string?)
1111   #:category font
1112   "
1113 @cindex simple text strings
1114
1115 A simple text string; @code{\\markup @{ foo @}} is equivalent with
1116 @code{\\markup @{ \\simple #\"foo\" @}}.
1117
1118 Note: for creating standard text markup or defining new markup commands,
1119 the use of @code{\\simple} is unnecessary.
1120
1121 @lilypond[verbatim,quote]
1122 \\markup {
1123   \\simple #\"simple\"
1124   \\simple #\"text\"
1125   \\simple #\"strings\"
1126 }
1127 @end lilypond"
1128   (interpret-markup layout props str))
1129
1130 (define-markup-command (tied-lyric layout props str)
1131   (string?)
1132   #:category music
1133   #:properties ((word-space))
1134   "
1135 @cindex simple text strings with tie characters
1136
1137 Like simple-markup, but use tie characters for @q{~} tilde symbols.
1138
1139 @lilypond[verbatim,quote]
1140 \\markup \\column {
1141   \\tied-lyric #\"Siam navi~all'onde~algenti Lasciate~in abbandono\"
1142   \\tied-lyric #\"Impetuosi venti I nostri~affetti sono\"
1143   \\tied-lyric #\"Ogni diletto~e scoglio Tutta la vita~e~un mar.\"
1144 }
1145 @end lilypond"
1146   (define (replace-ties tie str)
1147     (if (string-contains str "~")
1148         (let*
1149             ((half-space (/ word-space 2))
1150              (parts (string-split str #\~))
1151              (tie-str (markup #:hspace half-space
1152                               #:musicglyph tie
1153                               #:hspace half-space))
1154              (joined  (list-join parts tie-str)))
1155           (make-concat-markup joined))
1156         str))
1157
1158   (define short-tie-regexp (make-regexp "~[^.]~"))
1159   (define (match-short str) (regexp-exec short-tie-regexp str))
1160
1161   (define (replace-short str mkp)
1162     (let ((match (match-short str)))
1163       (if (not match)
1164           (make-concat-markup (list
1165                                mkp
1166                                (replace-ties "ties.lyric.default" str)))
1167           (let ((new-str (match:suffix match))
1168                 (new-mkp (make-concat-markup (list
1169                                               mkp
1170                                               (replace-ties "ties.lyric.default"
1171                                                             (match:prefix match))
1172                                               (replace-ties "ties.lyric.short"
1173                                                             (match:substring match))))))
1174             (replace-short new-str new-mkp)))))
1175
1176   (interpret-markup layout
1177                     props
1178                     (replace-short str (markup))))
1179
1180 (define-public empty-markup
1181   (make-simple-markup ""))
1182
1183 ;; helper for justifying lines.
1184 (define (get-fill-space word-count line-width word-space text-widths)
1185   "Calculate the necessary paddings between each two adjacent texts.
1186   The lengths of all texts are stored in @var{text-widths}.
1187   The normal formula for the padding between texts a and b is:
1188   padding = line-width/(word-count - 1) - (length(a) + length(b))/2
1189   The first and last padding have to be calculated specially using the
1190   whole length of the first or last text.
1191   All paddings are checked to be at least word-space, to ensure that
1192   no texts collide.
1193   Return a list of paddings."
1194   (cond
1195    ((null? text-widths) '())
1196
1197    ;; special case first padding
1198    ((= (length text-widths) word-count)
1199     (cons
1200      (- (- (/ line-width (1- word-count)) (car text-widths))
1201         (/ (car (cdr text-widths)) 2))
1202      (get-fill-space word-count line-width word-space (cdr text-widths))))
1203    ;; special case last padding
1204    ((= (length text-widths) 2)
1205     (list (- (/ line-width (1- word-count))
1206              (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
1207    (else
1208     (let ((default-padding
1209             (- (/ line-width (1- word-count))
1210                (/ (+ (car text-widths) (car (cdr text-widths))) 2))))
1211       (cons
1212        (if (> word-space default-padding)
1213            word-space
1214            default-padding)
1215        (get-fill-space word-count line-width word-space (cdr text-widths)))))))
1216
1217 (define-markup-command (fill-line layout props args)
1218   (markup-list?)
1219   #:category align
1220   #:properties ((text-direction RIGHT)
1221                 (word-space 0.6)
1222                 (line-width #f))
1223   "Put @var{markups} in a horizontal line of width @var{line-width}.
1224 The markups are spaced or flushed to fill the entire line.
1225 If there are no arguments, return an empty stencil.
1226
1227 @lilypond[verbatim,quote]
1228 \\markup {
1229   \\column {
1230     \\fill-line {
1231       Words evenly spaced across the page
1232     }
1233     \\null
1234     \\fill-line {
1235       \\line { Text markups }
1236       \\line {
1237         \\italic { evenly spaced }
1238       }
1239       \\line { across the page }
1240     }
1241   }
1242 }
1243 @end lilypond"
1244   (let* ((orig-stencils (interpret-markup-list layout props args))
1245          (stencils
1246           (map (lambda (stc)
1247                  (if (ly:stencil-empty? stc)
1248                      point-stencil
1249                      stc)) orig-stencils))
1250          (text-widths
1251           (map (lambda (stc)
1252                  (if (ly:stencil-empty? stc)
1253                      0.0
1254                      (interval-length (ly:stencil-extent stc X))))
1255                stencils))
1256          (text-width (apply + text-widths))
1257          (word-count (length stencils))
1258          (line-width (or line-width (ly:output-def-lookup layout 'line-width)))
1259          (fill-space
1260           (cond
1261            ((= word-count 1)
1262             (list
1263              (/ (- line-width text-width) 2)
1264              (/ (- line-width text-width) 2)))
1265            ((= word-count 2)
1266             (list
1267              (- line-width text-width)))
1268            (else
1269             (get-fill-space word-count line-width word-space text-widths))))
1270
1271          (line-contents (if (= word-count 1)
1272                             (list
1273                              point-stencil
1274                              (car stencils)
1275                              point-stencil)
1276                             stencils)))
1277
1278     (if (null? (remove ly:stencil-empty? orig-stencils))
1279         empty-stencil
1280         (begin
1281           (if (= text-direction LEFT)
1282               (set! line-contents (reverse line-contents)))
1283           (set! line-contents
1284                 (stack-stencils-padding-list
1285                  X RIGHT fill-space line-contents))
1286           (if (> word-count 1)
1287               ;; shift s.t. stencils align on the left edge, even if
1288               ;; first stencil had negative X-extent (e.g. center-column)
1289               ;; (if word-count = 1, X-extents are already normalized in
1290               ;; the definition of line-contents)
1291               (set! line-contents
1292                     (ly:stencil-translate-axis
1293                      line-contents
1294                      (- (car (ly:stencil-extent (car stencils) X)))
1295                      X)))
1296           line-contents))))
1297
1298 (define-markup-command (line layout props args)
1299   (markup-list?)
1300   #:category align
1301   #:properties ((word-space)
1302                 (text-direction RIGHT))
1303   "Put @var{args} in a horizontal line.  The property @code{word-space}
1304 determines the space between markups in @var{args}.
1305
1306 @lilypond[verbatim,quote]
1307 \\markup {
1308   \\line {
1309     one two three
1310   }
1311 }
1312 @end lilypond"
1313   (let ((stencils (interpret-markup-list layout props args)))
1314     (if (= text-direction LEFT)
1315         (set! stencils (reverse stencils)))
1316     (stack-stencil-line word-space stencils)))
1317
1318 (define-markup-command (concat layout props args)
1319   (markup-list?)
1320   #:category align
1321   "
1322 @cindex concatenating text
1323 @cindex ligatures in text
1324
1325 Concatenate @var{args} in a horizontal line, without spaces in between.
1326 Strings and simple markups are concatenated on the input level, allowing
1327 ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
1328 equivalent to @code{\"fi\"}.
1329
1330 @lilypond[verbatim,quote]
1331 \\markup {
1332   \\concat {
1333     one
1334     two
1335     three
1336   }
1337 }
1338 @end lilypond"
1339   (define (concat-string-args arg-list)
1340     (fold-right (lambda (arg result-list)
1341                   (let ((result (if (pair? result-list)
1342                                     (car result-list)
1343                                     '())))
1344                     (if (and (pair? arg) (eqv? (car arg) simple-markup))
1345                         (set! arg (cadr arg)))
1346                     (if (and (string? result) (string? arg))
1347                         (cons (string-append arg result) (cdr result-list))
1348                         (cons arg result-list))))
1349                 '()
1350                 arg-list))
1351
1352   (interpret-markup layout
1353                     (prepend-alist-chain 'word-space 0 props)
1354                     (make-line-markup
1355                      (make-override-lines-markup-list
1356                       (cons 'word-space
1357                             (chain-assoc-get 'word-space props))
1358                       (if (markup-command-list? args)
1359                           args
1360                           (concat-string-args args))))))
1361
1362 (define (wordwrap-stencils stencils
1363                            justify base-space line-width text-dir)
1364   "Perform simple wordwrap, return stencil of each line."
1365   (define space (if justify
1366                     ;; justify only stretches lines.
1367                     (* 0.7 base-space)
1368                     base-space))
1369   (define (stencil-len s)
1370     (interval-end (ly:stencil-extent s X)))
1371   (define (maybe-shift line)
1372     (if (= text-dir LEFT)
1373         (ly:stencil-translate-axis
1374          line
1375          (- line-width (stencil-len line))
1376          X)
1377         line))
1378   (if (null? stencils)
1379       '()
1380       (let loop ((lines '())
1381                  (todo stencils))
1382         (let word-loop
1383             ((line (first todo))
1384              (todo (cdr todo))
1385              (word-list (list (first todo))))
1386           (cond
1387            ((pair? todo)
1388             (let ((new (if (= text-dir LEFT)
1389                            (ly:stencil-stack (car todo) X RIGHT line space)
1390                            (ly:stencil-stack line X RIGHT (car todo) space))))
1391               (cond
1392                ((<= (stencil-len new) line-width)
1393                 (word-loop new (cdr todo)
1394                            (cons (car todo) word-list)))
1395                (justify
1396                 (let* ((word-list
1397                         ;; This depends on stencil stacking being
1398                         ;; associative so that stacking
1399                         ;; left-to-right and right-to-left leads to
1400                         ;; the same result
1401                         (if (= text-dir LEFT)
1402                             word-list
1403                             (reverse! word-list)))
1404                        (len (stencil-len line))
1405                        (stretch (- line-width len))
1406                        (spaces
1407                         (- (stencil-len
1408                             (stack-stencils X RIGHT (1+ space) word-list))
1409                            len)))
1410                   (if (zero? spaces)
1411                       ;; Uh oh, nothing to fill.
1412                       (loop (cons (maybe-shift line) lines) todo)
1413                       (loop (cons
1414                              (stack-stencils X RIGHT
1415                                              (+ space (/ stretch spaces))
1416                                              word-list)
1417                              lines)
1418                             todo))))
1419                (else ;; not justify
1420                 (loop (cons (maybe-shift line) lines) todo)))))
1421            ;; todo is null
1422            (justify
1423             ;; Now we have the last line assembled with space
1424             ;; which is compressed.  We want to use the
1425             ;; uncompressed version instead if it fits, and the
1426             ;; justified version if it doesn't.
1427             (let* ((word-list
1428                     ;; This depends on stencil stacking being
1429                     ;; associative so that stacking
1430                     ;; left-to-right and right-to-left leads to
1431                     ;; the same result
1432                     (if (= text-dir LEFT)
1433                         word-list
1434                         (reverse! word-list)))
1435                    (big-line (stack-stencils X RIGHT base-space word-list))
1436                    (big-len (stencil-len big-line))
1437                    (len (stencil-len line)))
1438               (reverse! lines
1439                         (list
1440                          (if (> big-len line-width)
1441                              (stack-stencils X RIGHT
1442                                              (/
1443                                               (+
1444                                                (* (- big-len line-width)
1445                                                   space)
1446                                                (* (- line-width len)
1447                                                   base-space))
1448                                               (- big-len len))
1449                                              word-list)
1450                              (maybe-shift big-line))))))
1451            (else ;; not justify
1452             (reverse! lines (list (maybe-shift line)))))))))
1453
1454
1455 (define-markup-list-command (wordwrap-internal layout props justify args)
1456   (boolean? markup-list?)
1457   #:properties ((line-width #f)
1458                 (word-space)
1459                 (text-direction RIGHT))
1460   "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}."
1461   (wordwrap-stencils (interpret-markup-list layout props args)
1462                      justify
1463                      word-space
1464                      (or line-width
1465                          (ly:output-def-lookup layout 'line-width))
1466                      text-direction))
1467
1468 (define-markup-command (justify layout props args)
1469   (markup-list?)
1470   #:category align
1471   #:properties ((baseline-skip)
1472                 wordwrap-internal-markup-list)
1473   "
1474 @cindex justifying text
1475
1476 Like @code{\\wordwrap}, but with lines stretched to justify the margins.
1477 Use @code{\\override #'(line-width . @var{X})} to set the line width;
1478 @var{X}@tie{}is the number of staff spaces.
1479
1480 @lilypond[verbatim,quote]
1481 \\markup {
1482   \\justify {
1483     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1484     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1485     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1486     laboris nisi ut aliquip ex ea commodo consequat.
1487   }
1488 }
1489 @end lilypond"
1490   (stack-lines DOWN 0.0 baseline-skip
1491                (wordwrap-internal-markup-list layout props #t args)))
1492
1493 (define-markup-command (wordwrap layout props args)
1494   (markup-list?)
1495   #:category align
1496   #:properties ((baseline-skip)
1497                 wordwrap-internal-markup-list)
1498   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
1499 the line width, where @var{X} is the number of staff spaces.
1500
1501 @lilypond[verbatim,quote]
1502 \\markup {
1503   \\wordwrap {
1504     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1505     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1506     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1507     laboris nisi ut aliquip ex ea commodo consequat.
1508   }
1509 }
1510 @end lilypond"
1511   (stack-lines DOWN 0.0 baseline-skip
1512                (wordwrap-internal-markup-list layout props #f args)))
1513
1514 (define-markup-list-command (wordwrap-string-internal layout props justify arg)
1515   (boolean? string?)
1516   #:properties ((line-width)
1517                 (word-space)
1518                 (text-direction RIGHT))
1519   "Internal markup list command used to define @code{\\justify-string} and
1520 @code{\\wordwrap-string}."
1521   (let* ((para-strings (regexp-split
1522                         (string-regexp-substitute
1523                          "\r" "\n"
1524                          (string-regexp-substitute "\r\n" "\n" arg))
1525                         "\n[ \t\n]*\n[ \t\n]*"))
1526          (list-para-words (map (lambda (str)
1527                                  (regexp-split str "[ \t\n]+"))
1528                                para-strings))
1529          (para-lines (map (lambda (words)
1530                             (let* ((stencils
1531                                     (map (lambda (x)
1532                                            (interpret-markup layout props x))
1533                                          words)))
1534                               (wordwrap-stencils stencils
1535                                                  justify word-space
1536                                                  line-width text-direction)))
1537                           list-para-words)))
1538     (concatenate para-lines)))
1539
1540 (define-markup-command (wordwrap-string layout props arg)
1541   (string?)
1542   #:category align
1543   #:properties ((baseline-skip)
1544                 wordwrap-string-internal-markup-list)
1545   "Wordwrap a string.  Paragraphs may be separated with double newlines.
1546
1547 @lilypond[verbatim,quote]
1548 \\markup {
1549   \\override #'(line-width . 40)
1550   \\wordwrap-string #\"Lorem ipsum dolor sit amet, consectetur
1551       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1552       et dolore magna aliqua.
1553
1554
1555       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1556       laboris nisi ut aliquip ex ea commodo consequat.
1557
1558
1559       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1560       qui officia deserunt mollit anim id est laborum\"
1561 }
1562 @end lilypond"
1563   (stack-lines DOWN 0.0 baseline-skip
1564                (wordwrap-string-internal-markup-list layout props #f arg)))
1565
1566 (define-markup-command (justify-string layout props arg)
1567   (string?)
1568   #:category align
1569   #:properties ((baseline-skip)
1570                 wordwrap-string-internal-markup-list)
1571   "Justify a string.  Paragraphs may be separated with double newlines
1572
1573 @lilypond[verbatim,quote]
1574 \\markup {
1575   \\override #'(line-width . 40)
1576   \\justify-string #\"Lorem ipsum dolor sit amet, consectetur
1577       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1578       et dolore magna aliqua.
1579
1580
1581       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1582       laboris nisi ut aliquip ex ea commodo consequat.
1583
1584
1585       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1586       qui officia deserunt mollit anim id est laborum\"
1587 }
1588 @end lilypond"
1589   (stack-lines DOWN 0.0 baseline-skip
1590                (wordwrap-string-internal-markup-list layout props #t arg)))
1591
1592 (define-markup-command (wordwrap-field layout props symbol)
1593   (symbol?)
1594   #:category align
1595   "Wordwrap the data which has been assigned to @var{symbol}.
1596
1597 @lilypond[verbatim,quote]
1598 \\header {
1599   title = \"My title\"
1600   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1601     elit, sed do eiusmod tempor incididunt ut labore et dolore
1602     magna aliqua.  Ut enim ad minim veniam, quis nostrud
1603     exercitation ullamco laboris nisi ut aliquip ex ea commodo
1604     consequat.\"
1605 }
1606
1607 \\paper {
1608   bookTitleMarkup = \\markup {
1609     \\column {
1610       \\fill-line { \\fromproperty #'header:title }
1611       \\null
1612       \\wordwrap-field #'header:myText
1613     }
1614   }
1615 }
1616
1617 \\markup {
1618   \\null
1619 }
1620 @end lilypond"
1621   (let* ((m (chain-assoc-get symbol props)))
1622     (if (string? m)
1623         (wordwrap-string-markup layout props m)
1624         empty-stencil)))
1625
1626 (define-markup-command (justify-field layout props symbol)
1627   (symbol?)
1628   #:category align
1629   "Justify the data which has been assigned to @var{symbol}.
1630
1631 @lilypond[verbatim,quote]
1632 \\header {
1633   title = \"My title\"
1634   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1635     elit, sed do eiusmod tempor incididunt ut labore et dolore magna
1636     aliqua.  Ut enim ad minim veniam, quis nostrud exercitation ullamco
1637     laboris nisi ut aliquip ex ea commodo consequat.\"
1638 }
1639
1640 \\paper {
1641   bookTitleMarkup = \\markup {
1642     \\column {
1643       \\fill-line { \\fromproperty #'header:title }
1644       \\null
1645       \\justify-field #'header:myText
1646     }
1647   }
1648 }
1649
1650 \\markup {
1651   \\null
1652 }
1653 @end lilypond"
1654   (let* ((m (chain-assoc-get symbol props)))
1655     (if (string? m)
1656         (justify-string-markup layout props m)
1657         empty-stencil)))
1658
1659 (define-markup-command (combine layout props arg1 arg2)
1660   (markup? markup?)
1661   #:category align
1662   "
1663 @cindex merging text
1664
1665 Print two markups on top of each other.
1666
1667 Note: @code{\\combine} cannot take a list of markups enclosed in
1668 curly braces as an argument; the follow example will not compile:
1669
1670 @example
1671 \\combine @{ a list @}
1672 @end example
1673
1674 @lilypond[verbatim,quote]
1675 \\markup {
1676   \\fontsize #5
1677   \\override #'(thickness . 2)
1678   \\combine
1679     \\draw-line #'(0 . 4)
1680     \\arrow-head #Y #DOWN ##f
1681 }
1682 @end lilypond"
1683   (let* ((s1 (interpret-markup layout props arg1))
1684          (s2 (interpret-markup layout props arg2)))
1685     (ly:stencil-add s1 s2)))
1686
1687 ;;
1688 ;; TODO: should extract baseline-skip from each argument somehow..
1689 ;;
1690 (define-markup-command (column layout props args)
1691   (markup-list?)
1692   #:category align
1693   #:properties ((baseline-skip))
1694   "
1695 @cindex stacking text in a column
1696
1697 Stack the markups in @var{args} vertically.  The property
1698 @code{baseline-skip} determines the space between markups
1699 in @var{args}.
1700
1701 @lilypond[verbatim,quote]
1702 \\markup {
1703   \\column {
1704     one
1705     two
1706     three
1707   }
1708 }
1709 @end lilypond"
1710   (let ((arg-stencils (interpret-markup-list layout props args)))
1711     (stack-lines -1 0.0 baseline-skip arg-stencils)))
1712
1713 (define-markup-command (dir-column layout props args)
1714   (markup-list?)
1715   #:category align
1716   #:properties ((direction)
1717                 (baseline-skip))
1718   "
1719 @cindex changing direction of text columns
1720
1721 Make a column of @var{args}, going up or down, depending on the
1722 setting of the @code{direction} layout property.
1723
1724 @lilypond[verbatim,quote]
1725 \\markup {
1726   \\override #`(direction . ,UP) {
1727     \\dir-column {
1728       going up
1729     }
1730   }
1731   \\hspace #1
1732   \\dir-column {
1733     going down
1734   }
1735   \\hspace #1
1736   \\override #'(direction . 1) {
1737     \\dir-column {
1738       going up
1739     }
1740   }
1741 }
1742 @end lilypond"
1743   (stack-lines (if (number? direction) direction -1)
1744                0.0
1745                baseline-skip
1746                (interpret-markup-list layout props args)))
1747
1748 (define (general-column align-dir baseline mols)
1749   "Stack @var{mols} vertically, aligned to  @var{align-dir} horizontally."
1750
1751   (let* ((aligned-mols (map (lambda (x) (ly:stencil-aligned-to x X align-dir)) mols))
1752          (stacked-stencil (stack-lines -1 0.0 baseline aligned-mols))
1753          (stacked-extent (ly:stencil-extent stacked-stencil X)))
1754     (ly:stencil-translate-axis stacked-stencil (- (car stacked-extent)) X )))
1755
1756 (define-markup-command (center-column layout props args)
1757   (markup-list?)
1758   #:category align
1759   #:properties ((baseline-skip))
1760   "
1761 @cindex centering a column of text
1762
1763 Put @code{args} in a centered column.
1764
1765 @lilypond[verbatim,quote]
1766 \\markup {
1767   \\center-column {
1768     one
1769     two
1770     three
1771   }
1772 }
1773 @end lilypond"
1774   (general-column CENTER baseline-skip (interpret-markup-list layout props args)))
1775
1776 (define-markup-command (left-column layout props args)
1777   (markup-list?)
1778   #:category align
1779   #:properties ((baseline-skip))
1780   "
1781 @cindex text columns, left-aligned
1782
1783 Put @code{args} in a left-aligned column.
1784
1785 @lilypond[verbatim,quote]
1786 \\markup {
1787   \\left-column {
1788     one
1789     two
1790     three
1791   }
1792 }
1793 @end lilypond"
1794   (general-column LEFT baseline-skip (interpret-markup-list layout props args)))
1795
1796 (define-markup-command (right-column layout props args)
1797   (markup-list?)
1798   #:category align
1799   #:properties ((baseline-skip))
1800   "
1801 @cindex text columns, right-aligned
1802
1803 Put @code{args} in a right-aligned column.
1804
1805 @lilypond[verbatim,quote]
1806 \\markup {
1807   \\right-column {
1808     one
1809     two
1810     three
1811   }
1812 }
1813 @end lilypond"
1814   (general-column RIGHT baseline-skip (interpret-markup-list layout props args)))
1815
1816 (define-markup-command (vcenter layout props arg)
1817   (markup?)
1818   #:category align
1819   "
1820 @cindex vertically centering text
1821
1822 Align @code{arg} to its Y@tie{}center.
1823
1824 @lilypond[verbatim,quote]
1825 \\markup {
1826   one
1827   \\vcenter
1828   two
1829   three
1830 }
1831 @end lilypond"
1832   (let* ((mol (interpret-markup layout props arg)))
1833     (ly:stencil-aligned-to mol Y CENTER)))
1834
1835 (define-markup-command (center-align layout props arg)
1836   (markup?)
1837   #:category align
1838   "
1839 @cindex horizontally centering text
1840
1841 Align @code{arg} to its X@tie{}center.
1842
1843 @lilypond[verbatim,quote]
1844 \\markup {
1845   \\column {
1846     one
1847     \\center-align
1848     two
1849     three
1850   }
1851 }
1852 @end lilypond"
1853   (let* ((mol (interpret-markup layout props arg)))
1854     (ly:stencil-aligned-to mol X CENTER)))
1855
1856 (define-markup-command (right-align layout props arg)
1857   (markup?)
1858   #:category align
1859   "
1860 @cindex right aligning text
1861
1862 Align @var{arg} on its right edge.
1863
1864 @lilypond[verbatim,quote]
1865 \\markup {
1866   \\column {
1867     one
1868     \\right-align
1869     two
1870     three
1871   }
1872 }
1873 @end lilypond"
1874   (let* ((m (interpret-markup layout props arg)))
1875     (ly:stencil-aligned-to m X RIGHT)))
1876
1877 (define-markup-command (left-align layout props arg)
1878   (markup?)
1879   #:category align
1880   "
1881 @cindex left aligning text
1882
1883 Align @var{arg} on its left edge.
1884
1885 @lilypond[verbatim,quote]
1886 \\markup {
1887   \\column {
1888     one
1889     \\left-align
1890     two
1891     three
1892   }
1893 }
1894 @end lilypond"
1895   (let* ((m (interpret-markup layout props arg)))
1896     (ly:stencil-aligned-to m X LEFT)))
1897
1898 (define-markup-command (general-align layout props axis dir arg)
1899   (integer? number? markup?)
1900   #:category align
1901   "
1902 @cindex controlling general text alignment
1903
1904 Align @var{arg} in @var{axis} direction to the @var{dir} side.
1905
1906 @lilypond[verbatim,quote]
1907 \\markup {
1908   \\column {
1909     one
1910     \\general-align #X #LEFT
1911     two
1912     three
1913     \\null
1914     one
1915     \\general-align #X #CENTER
1916     two
1917     three
1918     \\null
1919     \\line {
1920       one
1921       \\general-align #Y #UP
1922       two
1923       three
1924     }
1925     \\null
1926     \\line {
1927       one
1928       \\general-align #Y #3.2
1929       two
1930       three
1931     }
1932   }
1933 }
1934 @end lilypond"
1935   (let* ((m (interpret-markup layout props arg)))
1936     (ly:stencil-aligned-to m axis dir)))
1937
1938 (define-markup-command (halign layout props dir arg)
1939   (number? markup?)
1940   #:category align
1941   "
1942 @cindex setting horizontal text alignment
1943
1944 Set horizontal alignment.  If @var{dir} is @w{@code{-1}}, then it is
1945 left-aligned, while @code{+1} is right.  Values in between interpolate
1946 alignment accordingly.
1947
1948 @lilypond[verbatim,quote]
1949 \\markup {
1950   \\column {
1951     one
1952     \\halign #LEFT
1953     two
1954     three
1955     \\null
1956     one
1957     \\halign #CENTER
1958     two
1959     three
1960     \\null
1961     one
1962     \\halign #RIGHT
1963     two
1964     three
1965     \\null
1966     one
1967     \\halign #-5
1968     two
1969     three
1970   }
1971 }
1972 @end lilypond"
1973   (let* ((m (interpret-markup layout props arg)))
1974     (ly:stencil-aligned-to m X dir)))
1975
1976 (define-markup-command (with-dimensions layout props x y arg)
1977   (number-pair? number-pair? markup?)
1978   #:category other
1979   "
1980 @cindex setting extent of text objects
1981
1982 Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}."
1983   (let* ((expr (ly:stencil-expr (interpret-markup layout props arg))))
1984     (ly:stencil-add
1985      (make-transparent-box-stencil x y)
1986      (ly:make-stencil
1987       `(delay-stencil-evaluation ,(delay expr))
1988       x y))))
1989
1990 (define-markup-command (pad-around layout props amount arg)
1991   (number? markup?)
1992   #:category align
1993   "Add padding @var{amount} all around @var{arg}.
1994
1995 @lilypond[verbatim,quote]
1996 \\markup {
1997   \\box {
1998     default
1999   }
2000   \\hspace #2
2001   \\box {
2002     \\pad-around #0.5 {
2003       padded
2004     }
2005   }
2006 }
2007 @end lilypond"
2008   (let* ((m (interpret-markup layout props arg))
2009          (x (interval-widen (ly:stencil-extent m X) amount))
2010          (y (interval-widen (ly:stencil-extent m Y) amount)))
2011     (ly:stencil-add (make-transparent-box-stencil x y)
2012                     m)))
2013
2014 (define-markup-command (pad-x layout props amount arg)
2015   (number? markup?)
2016   #:category align
2017   "
2018 @cindex padding text horizontally
2019
2020 Add padding @var{amount} around @var{arg} in the X@tie{}direction.
2021
2022 @lilypond[verbatim,quote]
2023 \\markup {
2024   \\box {
2025     default
2026   }
2027   \\hspace #4
2028   \\box {
2029     \\pad-x #2 {
2030       padded
2031     }
2032   }
2033 }
2034 @end lilypond"
2035   (let* ((m (interpret-markup layout props arg))
2036          (x (ly:stencil-extent m X))
2037          (y (ly:stencil-extent m Y)))
2038     (ly:make-stencil (ly:stencil-expr m)
2039                      (interval-widen x amount)
2040                      y)))
2041
2042 (define-markup-command (put-adjacent layout props axis dir arg1 arg2)
2043   (integer? ly:dir? markup? markup?)
2044   #:category align
2045   "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}."
2046   (let ((m1 (interpret-markup layout props arg1))
2047         (m2 (interpret-markup layout props arg2)))
2048     (ly:stencil-combine-at-edge m1 axis dir m2 0.0)))
2049
2050 (define-markup-command (transparent layout props arg)
2051   (markup?)
2052   #:category other
2053   "Make @var{arg} transparent.
2054
2055 @lilypond[verbatim,quote]
2056 \\markup {
2057   \\transparent {
2058     invisible text
2059   }
2060 }
2061 @end lilypond"
2062   (let* ((m (interpret-markup layout props arg))
2063          (x (ly:stencil-extent m X))
2064          (y (ly:stencil-extent m Y)))
2065     (ly:make-stencil (list 'transparent-stencil (ly:stencil-expr m)) x y)))
2066
2067 (define-markup-command (pad-to-box layout props x-ext y-ext arg)
2068   (number-pair? number-pair? markup?)
2069   #:category align
2070   "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space.
2071
2072 @lilypond[verbatim,quote]
2073 \\markup {
2074   \\box {
2075     default
2076   }
2077   \\hspace #4
2078   \\box {
2079     \\pad-to-box #'(0 . 10) #'(0 . 3) {
2080       padded
2081     }
2082   }
2083 }
2084 @end lilypond"
2085   (ly:stencil-add (make-transparent-box-stencil x-ext y-ext)
2086                   (interpret-markup layout props arg)))
2087
2088 (define-markup-command (hcenter-in layout props length arg)
2089   (number? markup?)
2090   #:category align
2091   "Center @var{arg} horizontally within a box of extending
2092 @var{length}/2 to the left and right.
2093
2094 @lilypond[quote,verbatim]
2095 \\new StaffGroup <<
2096   \\new Staff {
2097     \\set Staff.instrumentName = \\markup {
2098       \\hcenter-in #12
2099       Oboe
2100     }
2101     c''1
2102   }
2103   \\new Staff {
2104     \\set Staff.instrumentName = \\markup {
2105       \\hcenter-in #12
2106       Bassoon
2107     }
2108     \\clef tenor
2109     c'1
2110   }
2111 >>
2112 @end lilypond"
2113   (interpret-markup layout props
2114                     (make-pad-to-box-markup
2115                      (cons (/ length -2) (/ length 2))
2116                      '(0 . 0)
2117                      (make-center-align-markup arg))))
2118
2119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2120 ;; property
2121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2122
2123 (define-markup-command (property-recursive layout props symbol)
2124   (symbol?)
2125   #:category other
2126   "Print out a warning when a header field markup contains some recursive
2127 markup definition."
2128   (ly:warning "Recursive definition of property ~a detected!" symbol)
2129   empty-stencil)
2130
2131 (define-markup-command (fromproperty layout props symbol)
2132   (symbol?)
2133   #:category other
2134   "Read the @var{symbol} from property settings, and produce a stencil
2135 from the markup contained within.  If @var{symbol} is not defined, it
2136 returns an empty markup.
2137
2138 @lilypond[verbatim,quote]
2139 \\header {
2140   myTitle = \"myTitle\"
2141   title = \\markup {
2142     from
2143     \\italic
2144     \\fromproperty #'header:myTitle
2145   }
2146 }
2147 \\markup {
2148   \\null
2149 }
2150 @end lilypond"
2151   (let ((m (chain-assoc-get symbol props)))
2152     (if (markup? m)
2153         ;; prevent infinite loops by clearing the interpreted property:
2154         (interpret-markup layout (cons (list (cons symbol `(,property-recursive-markup ,symbol))) props) m)
2155         empty-stencil)))
2156
2157 (define-markup-command (on-the-fly layout props procedure arg)
2158   (procedure? markup?)
2159   #:category other
2160   "Apply the @var{procedure} markup command to @var{arg}.
2161 @var{procedure} should take a single argument."
2162   (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
2163     (set-object-property! anonymous-with-signature
2164                           'markup-signature
2165                           (list markup?))
2166     (interpret-markup layout props (list anonymous-with-signature arg))))
2167
2168 (define-markup-command (footnote layout props mkup note)
2169   (markup? markup?)
2170   #:category other
2171   "Have footnote @var{note} act as an annotation to the markup @var{mkup}.
2172
2173 @lilypond[verbatim,quote]
2174 \\markup {
2175   \\auto-footnote a b
2176   \\override #'(padding . 0.2)
2177   \\auto-footnote c d
2178 }
2179 @end lilypond
2180 The footnote will not be annotated automatically."
2181   (ly:stencil-combine-at-edge
2182    (interpret-markup layout props mkup)
2183    X
2184    RIGHT
2185    (ly:make-stencil
2186     `(footnote (gensym "footnote") #f ,(interpret-markup layout props note))
2187     '(0 . 0)
2188     '(0 . 0))
2189    0.0))
2190
2191 (define-markup-command (auto-footnote layout props mkup note)
2192   (markup? markup?)
2193   #:category other
2194   #:properties ((raise 0.5)
2195                 (padding 0.0))
2196   "Have footnote @var{note} act as an annotation to the markup @var{mkup}.
2197
2198 @lilypond[verbatim,quote]
2199 \\markup {
2200   \\auto-footnote a b
2201   \\override #'(padding . 0.2)
2202   \\auto-footnote c d
2203 }
2204 @end lilypond
2205 The footnote will be annotated automatically."
2206   (let* ((markup-stencil (interpret-markup layout props mkup))
2207          (footnote-hash (gensym "footnote"))
2208          (stencil-seed 0)
2209          (gauge-stencil (interpret-markup
2210                          layout
2211                          props
2212                          ((ly:output-def-lookup
2213                            layout
2214                            'footnote-numbering-function)
2215                           stencil-seed)))
2216          (x-ext (ly:stencil-extent gauge-stencil X))
2217          (y-ext (ly:stencil-extent gauge-stencil Y))
2218          (footnote-number
2219           `(delay-stencil-evaluation
2220             ,(delay
2221                (ly:stencil-expr
2222                 (let* ((table
2223                         (ly:output-def-lookup layout
2224                                               'number-footnote-table))
2225                        (footnote-stencil (if (list? table)
2226                                              (assoc-get footnote-hash
2227                                                         table)
2228                                              empty-stencil))
2229                        (footnote-stencil (if (ly:stencil? footnote-stencil)
2230                                              footnote-stencil
2231                                              (begin
2232                                                (ly:programming-error
2233                                                 "Cannot find correct footnote for a markup object.")
2234                                                empty-stencil)))
2235                        (gap (- (interval-length x-ext)
2236                                (interval-length
2237                                 (ly:stencil-extent footnote-stencil X))))
2238                        (y-trans (- (+ (cdr y-ext)
2239                                       raise)
2240                                    (cdr (ly:stencil-extent footnote-stencil
2241                                                            Y)))))
2242                   (ly:stencil-translate footnote-stencil
2243                                         (cons gap y-trans)))))))
2244          (main-stencil (ly:stencil-combine-at-edge
2245                         markup-stencil
2246                         X
2247                         RIGHT
2248                         (ly:make-stencil footnote-number x-ext y-ext)
2249                         padding)))
2250     (ly:stencil-add
2251      main-stencil
2252      (ly:make-stencil
2253       `(footnote ,footnote-hash #t ,(interpret-markup layout props note))
2254       '(0 . 0)
2255       '(0 . 0)))))
2256
2257 (define-markup-command (override layout props new-prop arg)
2258   (pair? markup?)
2259   #:category other
2260   "
2261 @cindex overriding properties within text markup
2262
2263 Add the argument @var{new-prop} to the property list.  Properties
2264 may be any property supported by @rinternals{font-interface},
2265 @rinternals{text-interface} and
2266 @rinternals{instrument-specific-markup-interface}.
2267
2268 @lilypond[verbatim,quote]
2269 \\markup {
2270   \\line {
2271     \\column {
2272       default
2273       baseline-skip
2274     }
2275     \\hspace #2
2276     \\override #'(baseline-skip . 4) {
2277       \\column {
2278         increased
2279         baseline-skip
2280       }
2281     }
2282   }
2283 }
2284 @end lilypond"
2285   (interpret-markup layout (cons (list new-prop) props) arg))
2286
2287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2288 ;; files
2289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2290
2291 (define-markup-command (verbatim-file layout props name)
2292   (string?)
2293   #:category other
2294   "Read the contents of file @var{name}, and include it verbatim.
2295
2296 @lilypond[verbatim,quote]
2297 \\markup {
2298   \\verbatim-file #\"simple.ly\"
2299 }
2300 @end lilypond"
2301   (interpret-markup layout props
2302                     (if  (ly:get-option 'safe)
2303                          "verbatim-file disabled in safe mode"
2304                          (let* ((str (ly:gulp-file name))
2305                                 (lines (string-split str #\nl)))
2306                            (make-typewriter-markup
2307                             (make-column-markup lines))))))
2308
2309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2310 ;; fonts.
2311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2312
2313
2314 (define-markup-command (smaller layout props arg)
2315   (markup?)
2316   #:category font
2317   "Decrease the font size relative to the current setting.
2318
2319 @lilypond[verbatim,quote]
2320 \\markup {
2321   \\fontsize #3.5 {
2322     some large text
2323     \\hspace #2
2324     \\smaller {
2325       a bit smaller
2326     }
2327     \\hspace #2
2328     more large text
2329   }
2330 }
2331 @end lilypond"
2332   (interpret-markup layout props
2333                     `(,fontsize-markup -1 ,arg)))
2334
2335 (define-markup-command (larger layout props arg)
2336   (markup?)
2337   #:category font
2338   "Increase the font size relative to the current setting.
2339
2340 @lilypond[verbatim,quote]
2341 \\markup {
2342   default
2343   \\hspace #2
2344   \\larger
2345   larger
2346 }
2347 @end lilypond"
2348   (interpret-markup layout props
2349                     `(,fontsize-markup 1 ,arg)))
2350
2351 (define-markup-command (finger layout props arg)
2352   (markup?)
2353   #:category font
2354   "Set @var{arg} as small numbers.
2355
2356 @lilypond[verbatim,quote]
2357 \\markup {
2358   \\finger {
2359     1 2 3 4 5
2360   }
2361 }
2362 @end lilypond"
2363   (interpret-markup layout
2364                     (cons '((font-size . -5) (font-encoding . fetaText)) props)
2365                     arg))
2366
2367 (define-markup-command (abs-fontsize layout props size arg)
2368   (number? markup?)
2369   #:category font
2370   "Use @var{size} as the absolute font size to display @var{arg}.
2371 Adjusts @code{baseline-skip} and @code{word-space} accordingly.
2372
2373 @lilypond[verbatim,quote]
2374 \\markup {
2375   default text font size
2376   \\hspace #2
2377   \\abs-fontsize #16 { text font size 16 }
2378   \\hspace #2
2379   \\abs-fontsize #12 { text font size 12 }
2380 }
2381 @end lilypond"
2382   (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12))
2383          (text-props (list (ly:output-def-lookup layout 'text-font-defaults)))
2384          (ref-word-space (chain-assoc-get 'word-space text-props 0.6))
2385          (ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
2386          (magnification (/ size ref-size)))
2387     (interpret-markup
2388      layout
2389      (cons
2390       `((baseline-skip . ,(* magnification ref-baseline))
2391         (word-space . ,(* magnification ref-word-space))
2392         (font-size . ,(magnification->font-size magnification)))
2393       props)
2394      arg)))
2395
2396 (define-markup-command (fontsize layout props increment arg)
2397   (number? markup?)
2398   #:category font
2399   #:properties ((font-size 0)
2400                 (word-space 1)
2401                 (baseline-skip 2))
2402   "Add @var{increment} to the font-size.  Adjusts @code{baseline-skip}
2403 accordingly.
2404
2405 @lilypond[verbatim,quote]
2406 \\markup {
2407   default
2408   \\hspace #2
2409   \\fontsize #-1.5
2410   smaller
2411 }
2412 @end lilypond"
2413   (interpret-markup
2414    layout
2415    (cons
2416     `((baseline-skip . ,(* baseline-skip (magstep increment)))
2417       (word-space . ,(* word-space (magstep increment)))
2418       (font-size . ,(+ font-size increment)))
2419     props)
2420    arg))
2421
2422 (define-markup-command (magnify layout props sz arg)
2423   (number? markup?)
2424   #:category font
2425   "
2426 @cindex magnifying text
2427
2428 Set the font magnification for its argument.  In the following
2429 example, the middle@tie{}A is 10% larger:
2430
2431 @example
2432 A \\magnify #1.1 @{ A @} A
2433 @end example
2434
2435 Note: Magnification only works if a font name is explicitly selected.
2436 Use @code{\\fontsize} otherwise.
2437
2438 @lilypond[verbatim,quote]
2439 \\markup {
2440   default
2441   \\hspace #2
2442   \\magnify #1.5 {
2443     50% larger
2444   }
2445 }
2446 @end lilypond"
2447   (interpret-markup
2448    layout
2449    (prepend-alist-chain 'font-size (magnification->font-size sz) props)
2450    arg))
2451
2452 (define-markup-command (bold layout props arg)
2453   (markup?)
2454   #:category font
2455   "Switch to bold font-series.
2456
2457 @lilypond[verbatim,quote]
2458 \\markup {
2459   default
2460   \\hspace #2
2461   \\bold
2462   bold
2463 }
2464 @end lilypond"
2465   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
2466
2467 (define-markup-command (sans layout props arg)
2468   (markup?)
2469   #:category font
2470   "Switch to the sans serif font family.
2471
2472 @lilypond[verbatim,quote]
2473 \\markup {
2474   default
2475   \\hspace #2
2476   \\sans {
2477     sans serif
2478   }
2479 }
2480 @end lilypond"
2481   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
2482
2483 (define-markup-command (number layout props arg)
2484   (markup?)
2485   #:category font
2486   "Set font family to @code{number}, which yields the font used for
2487 time signatures and fingerings.  This font contains numbers and
2488 some punctuation; it has no letters.
2489
2490 @lilypond[verbatim,quote]
2491 \\markup {
2492   \\number {
2493     0 1 2 3 4 5 6 7 8 9 . ,
2494   }
2495 }
2496 @end lilypond"
2497   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2498
2499 (define-markup-command (roman layout props arg)
2500   (markup?)
2501   #:category font
2502   "Set font family to @code{roman}.
2503
2504 @lilypond[verbatim,quote]
2505 \\markup {
2506   \\sans \\bold {
2507     sans serif, bold
2508     \\hspace #2
2509     \\roman {
2510       text in roman font family
2511     }
2512     \\hspace #2
2513     return to sans
2514   }
2515 }
2516 @end lilypond"
2517   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
2518
2519 (define-markup-command (huge layout props arg)
2520   (markup?)
2521   #:category font
2522   "Set font size to +2.
2523
2524 @lilypond[verbatim,quote]
2525 \\markup {
2526   default
2527   \\hspace #2
2528   \\huge
2529   huge
2530 }
2531 @end lilypond"
2532   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
2533
2534 (define-markup-command (large layout props arg)
2535   (markup?)
2536   #:category font
2537   "Set font size to +1.
2538
2539 @lilypond[verbatim,quote]
2540 \\markup {
2541   default
2542   \\hspace #2
2543   \\large
2544   large
2545 }
2546 @end lilypond"
2547   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
2548
2549 (define-markup-command (normalsize layout props arg)
2550   (markup?)
2551   #:category font
2552   "Set font size to default.
2553
2554 @lilypond[verbatim,quote]
2555 \\markup {
2556   \\teeny {
2557     this is very small
2558     \\hspace #2
2559     \\normalsize {
2560       normal size
2561     }
2562     \\hspace #2
2563     teeny again
2564   }
2565 }
2566 @end lilypond"
2567   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
2568
2569 (define-markup-command (small layout props arg)
2570   (markup?)
2571   #:category font
2572   "Set font size to -1.
2573
2574 @lilypond[verbatim,quote]
2575 \\markup {
2576   default
2577   \\hspace #2
2578   \\small
2579   small
2580 }
2581 @end lilypond"
2582   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
2583
2584 (define-markup-command (tiny layout props arg)
2585   (markup?)
2586   #:category font
2587   "Set font size to -2.
2588
2589 @lilypond[verbatim,quote]
2590 \\markup {
2591   default
2592   \\hspace #2
2593   \\tiny
2594   tiny
2595 }
2596 @end lilypond"
2597   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
2598
2599 (define-markup-command (teeny layout props arg)
2600   (markup?)
2601   #:category font
2602   "Set font size to -3.
2603
2604 @lilypond[verbatim,quote]
2605 \\markup {
2606   default
2607   \\hspace #2
2608   \\teeny
2609   teeny
2610 }
2611 @end lilypond"
2612   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
2613
2614 (define-markup-command (fontCaps layout props arg)
2615   (markup?)
2616   #:category font
2617   "Set @code{font-shape} to @code{caps}
2618
2619 Note: @code{\\fontCaps} requires the installation and selection of
2620 fonts which support the @code{caps} font shape."
2621   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
2622
2623 ;; Poor man's caps
2624 (define-markup-command (smallCaps layout props arg)
2625   (markup?)
2626   #:category font
2627   "Emit @var{arg} as small caps.
2628
2629 Note: @code{\\smallCaps} does not support accented characters.
2630
2631 @lilypond[verbatim,quote]
2632 \\markup {
2633   default
2634   \\hspace #2
2635   \\smallCaps {
2636     Text in small caps
2637   }
2638 }
2639 @end lilypond"
2640   (define (char-list->markup chars lower)
2641     (let ((final-string (string-upcase (reverse-list->string chars))))
2642       (if lower
2643           (markup #:fontsize -2 final-string)
2644           final-string)))
2645   (define (make-small-caps rest-chars currents current-is-lower prev-result)
2646     (if (null? rest-chars)
2647         (make-concat-markup
2648          (reverse! (cons (char-list->markup currents current-is-lower)
2649                          prev-result)))
2650         (let* ((ch (car rest-chars))
2651                (is-lower (char-lower-case? ch)))
2652           (if (or (and current-is-lower is-lower)
2653                   (and (not current-is-lower) (not is-lower)))
2654               (make-small-caps (cdr rest-chars)
2655                                (cons ch currents)
2656                                is-lower
2657                                prev-result)
2658               (make-small-caps (cdr rest-chars)
2659                                (list ch)
2660                                is-lower
2661                                (if (null? currents)
2662                                    prev-result
2663                                    (cons (char-list->markup
2664                                           currents current-is-lower)
2665                                          prev-result)))))))
2666   (interpret-markup layout props
2667                     (if (string? arg)
2668                         (make-small-caps (string->list arg) (list) #f (list))
2669                         arg)))
2670
2671 (define-markup-command (caps layout props arg)
2672   (markup?)
2673   #:category font
2674   "Copy of the @code{\\smallCaps} command.
2675
2676 @lilypond[verbatim,quote]
2677 \\markup {
2678   default
2679   \\hspace #2
2680   \\caps {
2681     Text in small caps
2682   }
2683 }
2684 @end lilypond"
2685   (interpret-markup layout props (make-smallCaps-markup arg)))
2686
2687 (define-markup-command (dynamic layout props arg)
2688   (markup?)
2689   #:category font
2690   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
2691 @b{z}, @b{p}, and @b{r}.  When producing phrases, like
2692 @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be
2693 done in a different font.  The recommended font for this is bold and italic.
2694 @lilypond[verbatim,quote]
2695 \\markup {
2696   \\dynamic {
2697     sfzp
2698   }
2699 }
2700 @end lilypond"
2701   (interpret-markup
2702    layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2703
2704 (define-markup-command (text layout props arg)
2705   (markup?)
2706   #:category font
2707   "Use a text font instead of music symbol or music alphabet font.
2708
2709 @lilypond[verbatim,quote]
2710 \\markup {
2711   \\number {
2712     1, 2,
2713     \\text {
2714       three, four,
2715     }
2716     5
2717   }
2718 }
2719 @end lilypond"
2720
2721   ;; ugh - latin1
2722   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
2723                     arg))
2724
2725 (define-markup-command (italic layout props arg)
2726   (markup?)
2727   #:category font
2728   "Use italic @code{font-shape} for @var{arg}.
2729
2730 @lilypond[verbatim,quote]
2731 \\markup {
2732   default
2733   \\hspace #2
2734   \\italic
2735   italic
2736 }
2737 @end lilypond"
2738   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
2739
2740 (define-markup-command (typewriter layout props arg)
2741   (markup?)
2742   #:category font
2743   "Use @code{font-family} typewriter for @var{arg}.
2744
2745 @lilypond[verbatim,quote]
2746 \\markup {
2747   default
2748   \\hspace #2
2749   \\typewriter
2750   typewriter
2751 }
2752 @end lilypond"
2753   (interpret-markup
2754    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
2755
2756 (define-markup-command (upright layout props arg)
2757   (markup?)
2758   #:category font
2759   "Set @code{font-shape} to @code{upright}.  This is the opposite
2760 of @code{italic}.
2761
2762 @lilypond[verbatim,quote]
2763 \\markup {
2764   \\italic {
2765     italic text
2766     \\hspace #2
2767     \\upright {
2768       upright text
2769     }
2770     \\hspace #2
2771     italic again
2772   }
2773 }
2774 @end lilypond"
2775   (interpret-markup
2776    layout (prepend-alist-chain 'font-shape 'upright props) arg))
2777
2778 (define-markup-command (medium layout props arg)
2779   (markup?)
2780   #:category font
2781   "Switch to medium font-series (in contrast to bold).
2782
2783 @lilypond[verbatim,quote]
2784 \\markup {
2785   \\bold {
2786     some bold text
2787     \\hspace #2
2788     \\medium {
2789       medium font series
2790     }
2791     \\hspace #2
2792     bold again
2793   }
2794 }
2795 @end lilypond"
2796   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
2797                     arg))
2798
2799 (define-markup-command (normal-text layout props arg)
2800   (markup?)
2801   #:category font
2802   "Set all font related properties (except the size) to get the default
2803 normal text font, no matter what font was used earlier.
2804
2805 @lilypond[verbatim,quote]
2806 \\markup {
2807   \\huge \\bold \\sans \\caps {
2808     huge bold sans caps
2809     \\hspace #2
2810     \\normal-text {
2811       huge normal
2812     }
2813     \\hspace #2
2814     as before
2815   }
2816 }
2817 @end lilypond"
2818   ;; ugh - latin1
2819   (interpret-markup layout
2820                     (cons '((font-family . roman) (font-shape . upright)
2821                             (font-series . medium) (font-encoding . latin1))
2822                           props)
2823                     arg))
2824
2825 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2826 ;; symbols.
2827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2828
2829 (define-markup-command (musicglyph layout props glyph-name)
2830   (string?)
2831   #:category music
2832   "@var{glyph-name} is converted to a musical symbol; for example,
2833 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
2834 the music font.  See @ruser{The Feta font} for a complete listing of
2835 the possible glyphs.
2836
2837 @lilypond[verbatim,quote]
2838 \\markup {
2839   \\musicglyph #\"f\"
2840   \\musicglyph #\"rests.2\"
2841   \\musicglyph #\"clefs.G_change\"
2842 }
2843 @end lilypond"
2844   (let* ((font (ly:paper-get-font layout
2845                                   (cons '((font-encoding . fetaMusic)
2846                                           (font-name . #f))
2847
2848                                         props)))
2849          (glyph (ly:font-get-glyph font glyph-name)))
2850     (if (null? (ly:stencil-expr glyph))
2851         (ly:warning (_ "Cannot find glyph ~a") glyph-name))
2852
2853     glyph))
2854
2855 (define-markup-command (doublesharp layout props)
2856   ()
2857   #:category music
2858   "Draw a double sharp symbol.
2859
2860 @lilypond[verbatim,quote]
2861 \\markup {
2862   \\doublesharp
2863 }
2864 @end lilypond"
2865   (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist ""))))
2866
2867 (define-markup-command (sesquisharp layout props)
2868   ()
2869   #:category music
2870   "Draw a 3/2 sharp symbol.
2871
2872 @lilypond[verbatim,quote]
2873 \\markup {
2874   \\sesquisharp
2875 }
2876 @end lilypond"
2877   (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist ""))))
2878
2879 (define-markup-command (sharp layout props)
2880   ()
2881   #:category music
2882   "Draw a sharp symbol.
2883
2884 @lilypond[verbatim,quote]
2885 \\markup {
2886   \\sharp
2887 }
2888 @end lilypond"
2889   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist ""))))
2890
2891 (define-markup-command (semisharp layout props)
2892   ()
2893   #:category music
2894   "Draw a semisharp symbol.
2895
2896 @lilypond[verbatim,quote]
2897 \\markup {
2898   \\semisharp
2899 }
2900 @end lilypond"
2901   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist ""))))
2902
2903 (define-markup-command (natural layout props)
2904   ()
2905   #:category music
2906   "Draw a natural symbol.
2907
2908 @lilypond[verbatim,quote]
2909 \\markup {
2910   \\natural
2911 }
2912 @end lilypond"
2913   (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist ""))))
2914
2915 (define-markup-command (semiflat layout props)
2916   ()
2917   #:category music
2918   "Draw a semiflat symbol.
2919
2920 @lilypond[verbatim,quote]
2921 \\markup {
2922   \\semiflat
2923 }
2924 @end lilypond"
2925   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist ""))))
2926
2927 (define-markup-command (flat layout props)
2928   ()
2929   #:category music
2930   "Draw a flat symbol.
2931
2932 @lilypond[verbatim,quote]
2933 \\markup {
2934   \\flat
2935 }
2936 @end lilypond"
2937   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist ""))))
2938
2939 (define-markup-command (sesquiflat layout props)
2940   ()
2941   #:category music
2942   "Draw a 3/2 flat symbol.
2943
2944 @lilypond[verbatim,quote]
2945 \\markup {
2946   \\sesquiflat
2947 }
2948 @end lilypond"
2949   (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist ""))))
2950
2951 (define-markup-command (doubleflat layout props)
2952   ()
2953   #:category music
2954   "Draw a double flat symbol.
2955
2956 @lilypond[verbatim,quote]
2957 \\markup {
2958   \\doubleflat
2959 }
2960 @end lilypond"
2961   (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist ""))))
2962
2963 (define-markup-command (with-color layout props color arg)
2964   (color? markup?)
2965   #:category other
2966   "
2967 @cindex coloring text
2968
2969 Draw @var{arg} in color specified by @var{color}.
2970
2971 @lilypond[verbatim,quote]
2972 \\markup {
2973   \\with-color #red
2974   red
2975   \\hspace #2
2976   \\with-color #green
2977   green
2978   \\hspace #2
2979   \\with-color #blue
2980   blue
2981 }
2982 @end lilypond"
2983   (let ((stil (interpret-markup layout props arg)))
2984     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
2985                      (ly:stencil-extent stil X)
2986                      (ly:stencil-extent stil Y))))
2987
2988 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2989 ;; glyphs
2990 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2991
2992 (define-markup-command (arrow-head layout props axis dir filled)
2993   (integer? ly:dir? boolean?)
2994   #:category graphic
2995   "Produce an arrow head in specified direction and axis.
2996 Use the filled head if @var{filled} is specified.
2997 @lilypond[verbatim,quote]
2998 \\markup {
2999   \\fontsize #5 {
3000     \\general-align #Y #DOWN {
3001       \\arrow-head #Y #UP ##t
3002       \\arrow-head #Y #DOWN ##f
3003       \\hspace #2
3004       \\arrow-head #X #RIGHT ##f
3005       \\arrow-head #X #LEFT ##f
3006     }
3007   }
3008 }
3009 @end lilypond"
3010   (let*
3011       ((name (format #f "arrowheads.~a.~a~a"
3012                      (if filled
3013                          "close"
3014                          "open")
3015                      axis
3016                      dir)))
3017     (ly:font-get-glyph
3018      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
3019                                      props))
3020      name)))
3021
3022 (define-markup-command (lookup layout props glyph-name)
3023   (string?)
3024   #:category other
3025   "Lookup a glyph by name.
3026
3027 @lilypond[verbatim,quote]
3028 \\markup {
3029   \\override #'(font-encoding . fetaBraces) {
3030     \\lookup #\"brace200\"
3031     \\hspace #2
3032     \\rotate #180
3033     \\lookup #\"brace180\"
3034   }
3035 }
3036 @end lilypond"
3037   (ly:font-get-glyph (ly:paper-get-font layout props)
3038                      glyph-name))
3039
3040 (define-markup-command (char layout props num)
3041   (integer?)
3042   #:category other
3043   "Produce a single character.  Characters encoded in hexadecimal
3044 format require the prefix @code{#x}.
3045
3046 @lilypond[verbatim,quote]
3047 \\markup {
3048   \\char #65 \\char ##x00a9
3049 }
3050 @end lilypond"
3051   (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num)))
3052
3053 (define number->mark-letter-vector (make-vector 25 #\A))
3054
3055 (do ((i 0 (1+ i))
3056      (j 0 (1+ j)))
3057     ((>= i 26))
3058   (if (= i (- (char->integer #\I) (char->integer #\A)))
3059       (set! i (1+ i)))
3060   (vector-set! number->mark-letter-vector j
3061                (integer->char (+ i (char->integer #\A)))))
3062
3063 (define number->mark-alphabet-vector (list->vector
3064                                       (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
3065
3066 (define (number->markletter-string vec n)
3067   "Double letters for big marks."
3068   (let* ((lst (vector-length vec)))
3069
3070     (if (>= n lst)
3071         (string-append (number->markletter-string vec (1- (quotient n lst)))
3072                        (number->markletter-string vec (remainder n lst)))
3073         (make-string 1 (vector-ref vec n)))))
3074
3075 (define-markup-command (markletter layout props num)
3076   (integer?)
3077   #:category other
3078   "Make a markup letter for @var{num}.  The letters start with A
3079 to@tie{}Z (skipping letter@tie{}I), and continue with double letters.
3080
3081 @lilypond[verbatim,quote]
3082 \\markup {
3083   \\markletter #8
3084   \\hspace #2
3085   \\markletter #26
3086 }
3087 @end lilypond"
3088   (ly:text-interface::interpret-markup layout props
3089                                        (number->markletter-string number->mark-letter-vector num)))
3090
3091 (define-markup-command (markalphabet layout props num)
3092   (integer?)
3093   #:category other
3094   "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
3095 and continue with double letters.
3096
3097 @lilypond[verbatim,quote]
3098 \\markup {
3099   \\markalphabet #8
3100   \\hspace #2
3101   \\markalphabet #26
3102 }
3103 @end lilypond"
3104   (ly:text-interface::interpret-markup layout props
3105                                        (number->markletter-string number->mark-alphabet-vector num)))
3106
3107 (define-public (horizontal-slash-interval num forward number-interval mag)
3108   (if forward
3109       (cond ;; ((= num 6) (interval-widen number-interval (* mag 0.5)))
3110        ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
3111        (else (interval-widen number-interval (* mag 0.25))))
3112       (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
3113             ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
3114             (else (interval-widen number-interval (* mag 0.25))))
3115       ))
3116
3117 (define-public (adjust-slash-stencil num forward stencil mag)
3118   (if forward
3119       (cond ((= num 2)
3120              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
3121             ((= num 3)
3122              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
3123             ;; ((= num 5)
3124             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
3125             ;; ((= num 7)
3126             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
3127             (else stencil))
3128       (cond ((= num 6)
3129              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
3130             ;; ((= num 8)
3131             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
3132             (else stencil))
3133       )
3134   )
3135
3136 (define (slashed-digit-internal layout props num forward font-size thickness)
3137   (let* ((mag (magstep font-size))
3138          (thickness (* mag
3139                        (ly:output-def-lookup layout 'line-thickness)
3140                        thickness))
3141          ;; backward slashes might use slope and point in the other direction!
3142          (dy (* mag (if forward 0.4 -0.4)))
3143          (number-stencil (interpret-markup layout
3144                                            (prepend-alist-chain 'font-encoding 'fetaText props)
3145                                            (number->string num)))
3146          (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag))
3147          (center (interval-center (ly:stencil-extent number-stencil Y)))
3148          ;; Use the real extents of the slash, not the whole number,
3149          ;; because we might translate the slash later on!
3150          (num-y (interval-widen (cons center center) (abs dy)))
3151          (is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
3152          (slash-stencil (if is-sane
3153                             (make-line-stencil thickness
3154                                                (car num-x) (- (interval-center num-y) dy)
3155                                                (cdr num-x) (+ (interval-center num-y) dy))
3156                             #f)))
3157     (if (ly:stencil? slash-stencil)
3158         (begin
3159           ;; for some numbers we need to shift the slash/backslash up or
3160           ;; down to make the slashed digit look better
3161           (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
3162           (set! number-stencil
3163                 (ly:stencil-add number-stencil slash-stencil)))
3164         (ly:warning "Unable to create slashed digit ~a" num))
3165     number-stencil))
3166
3167
3168 (define-markup-command (slashed-digit layout props num)
3169   (integer?)
3170   #:category other
3171   #:properties ((font-size 0)
3172                 (thickness 1.6))
3173   "
3174 @cindex slashed digits
3175
3176 A feta number, with slash.  This is for use in the context of
3177 figured bass notation.
3178 @lilypond[verbatim,quote]
3179 \\markup {
3180   \\slashed-digit #5
3181   \\hspace #2
3182   \\override #'(thickness . 3)
3183   \\slashed-digit #7
3184 }
3185 @end lilypond"
3186   (slashed-digit-internal layout props num #t font-size thickness))
3187
3188 (define-markup-command (backslashed-digit layout props num)
3189   (integer?)
3190   #:category other
3191   #:properties ((font-size 0)
3192                 (thickness 1.6))
3193   "
3194 @cindex backslashed digits
3195
3196 A feta number, with backslash.  This is for use in the context of
3197 figured bass notation.
3198 @lilypond[verbatim,quote]
3199 \\markup {
3200   \\backslashed-digit #5
3201   \\hspace #2
3202   \\override #'(thickness . 3)
3203   \\backslashed-digit #7
3204 }
3205 @end lilypond"
3206   (slashed-digit-internal layout props num #f font-size thickness))
3207
3208 ;; eyeglasses
3209 (define eyeglassespath
3210   '((moveto 0.42 0.77)
3211     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
3212     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
3213     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
3214     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
3215     (closepath)
3216     (moveto 2.07 0.77)
3217     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
3218     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
3219     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
3220     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
3221     (closepath)
3222     (moveto 1.025 0.935)
3223     (rcurveto 0 0.182 -0.148 0.33 -0.33 0.33)
3224     (rcurveto -0.182 0 -0.33 -0.148 -0.33 -0.33)
3225     (moveto -0.68 0.77)
3226     (rlineto 0.66 1.43)
3227     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)
3228     (moveto 2.07 0.77)
3229     (rlineto 0.66 1.43)
3230     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)))
3231
3232 (define-markup-command (eyeglasses layout props)
3233   ()
3234   #:category other
3235   "Prints out eyeglasses, indicating strongly to look at the conductor.
3236 @lilypond[verbatim,quote]
3237 \\markup { \\eyeglasses }
3238 @end lilypond"
3239   (interpret-markup layout props
3240                     (make-override-markup '(line-cap-style . butt)
3241                                           (make-path-markup 0.15 eyeglassespath))))
3242
3243 (define-markup-command (left-brace layout props size)
3244   (number?)
3245   #:category other
3246   "
3247 A feta brace in point size @var{size}.
3248
3249 @lilypond[verbatim,quote]
3250 \\markup {
3251   \\left-brace #35
3252   \\hspace #2
3253   \\left-brace #45
3254 }
3255 @end lilypond"
3256   (let* ((font (ly:paper-get-font layout
3257                                   (cons '((font-encoding . fetaBraces)
3258                                           (font-name . #f))
3259                                         props)))
3260          (glyph-count (1- (ly:otf-glyph-count font)))
3261          (scale (ly:output-def-lookup layout 'output-scale))
3262          (scaled-size (/ (ly:pt size) scale))
3263          (glyph (lambda (n)
3264                   (ly:font-get-glyph font (string-append "brace"
3265                                                          (number->string n)))))
3266          (get-y-from-brace (lambda (brace)
3267                              (interval-length
3268                               (ly:stencil-extent (glyph brace) Y))))
3269          (find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size))
3270          (glyph-found (glyph find-brace)))
3271
3272     (if (or (null? (ly:stencil-expr glyph-found))
3273             (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y)))
3274             (> scaled-size (interval-length
3275                             (ly:stencil-extent (glyph glyph-count) Y))))
3276         (begin
3277           (ly:warning (_ "no brace found for point size ~S ") size)
3278           (ly:warning (_ "defaulting to ~S pt")
3279                       (/ (* scale (interval-length
3280                                    (ly:stencil-extent glyph-found Y)))
3281                          (ly:pt 1)))))
3282     glyph-found))
3283
3284 (define-markup-command (right-brace layout props size)
3285   (number?)
3286   #:category other
3287   "
3288 A feta brace in point size @var{size}, rotated 180 degrees.
3289
3290 @lilypond[verbatim,quote]
3291 \\markup {
3292   \\right-brace #45
3293   \\hspace #2
3294   \\right-brace #35
3295 }
3296 @end lilypond"
3297   (interpret-markup layout props (markup #:rotate 180 #:left-brace size)))
3298
3299 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3300 ;; the note command.
3301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3302
3303 ;; TODO: better syntax.
3304
3305 (define-markup-command (note-by-number layout props log dot-count dir)
3306   (number? number? number?)
3307   #:category music
3308   #:properties ((font-size 0)
3309                 (flag-style '())
3310                 (style '()))
3311   "
3312 @cindex notes within text by log and dot-count
3313
3314 Construct a note symbol, with stem and flag.  By using fractional values for
3315 @var{dir}, longer or shorter stems can be obtained.
3316 Supports all note-head-styles.
3317 Supported flag-styles are @code{default}, @code{old-straight-flag},
3318 @code{modern-straight-flag} and @code{flat-flag}.
3319
3320 @lilypond[verbatim,quote]
3321 \\markup {
3322   \\note-by-number #3 #0 #DOWN
3323   \\hspace #2
3324   \\note-by-number #1 #2 #0.8
3325 }
3326 @end lilypond"
3327   (define (get-glyph-name-candidates dir log style)
3328     (map (lambda (dir-name)
3329            (format #f "noteheads.~a~a" dir-name
3330                    (if (and (symbol? style)
3331                             (not (equal? 'default style)))
3332                        (select-head-glyph style (min log 2))
3333                        (min log 2))))
3334          (list (if (= dir UP) "u" "d")
3335                "s")))
3336
3337   (define (get-glyph-name font cands)
3338     (if (null? cands)
3339         ""
3340         (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
3341             (get-glyph-name font (cdr cands))
3342             (car cands))))
3343
3344   (define (buildflags flag-stencil remain curr-stencil spacing)
3345     ;; Function to recursively create a stencil with @code{remain} flags
3346     ;; from the single-flag stencil @code{curr-stencil}, which is already
3347     ;; translated to the position of the previous flag position.
3348     ;;
3349     ;; Copy and paste from /scm/flag-styles.scm
3350     (if (> remain 0)
3351         (let* ((translated-stencil
3352                 (ly:stencil-translate-axis curr-stencil spacing Y))
3353                (new-stencil (ly:stencil-add flag-stencil translated-stencil)))
3354           (buildflags new-stencil (- remain 1) translated-stencil spacing))
3355         flag-stencil))
3356
3357   (define (straight-flag-mrkp flag-thickness flag-spacing
3358                               upflag-angle upflag-length
3359                               downflag-angle downflag-length
3360                               dir)
3361     ;; Create a stencil for a straight flag.  @var{flag-thickness} and
3362     ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and
3363     ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and
3364     ;; @var{downflag-length} are given in staff spaces.
3365     ;;
3366     ;; All lengths are scaled according to the font size of the note.
3367     ;;
3368     ;; From /scm/flag-styles.scm, modified to fit here.
3369
3370     (let* ((stem-up (> dir 0))
3371            ;; scale with the note size
3372            (factor (magstep font-size))
3373            (stem-thickness (* factor 0.1))
3374            (line-thickness (ly:output-def-lookup layout 'line-thickness))
3375            (half-stem-thickness (/ (* stem-thickness line-thickness) 2))
3376            (raw-length (if stem-up upflag-length downflag-length))
3377            (angle (if stem-up upflag-angle downflag-angle))
3378            (flag-length (+ (* raw-length factor) half-stem-thickness))
3379            (flag-end (if (= angle 0)
3380                          (cons flag-length (* half-stem-thickness dir))
3381                          (polar->rectangular flag-length angle)))
3382            (thickness (* flag-thickness factor))
3383            (thickness-offset (cons 0 (* -1 thickness dir)))
3384            (spacing (* -1 flag-spacing factor dir))
3385            (start (cons (- half-stem-thickness) (* half-stem-thickness dir)))
3386            ;; The points of a round-filled-polygon need to be given in
3387            ;; clockwise order, otherwise the polygon will be enlarged by
3388            ;; blot-size*2!
3389            (points (if stem-up
3390                        (list start
3391                              flag-end
3392                              (offset-add flag-end thickness-offset)
3393                              (offset-add start thickness-offset))
3394                        (list start
3395                              (offset-add start thickness-offset)
3396                              (offset-add flag-end thickness-offset)
3397                              flag-end)))
3398            (stencil (ly:round-filled-polygon points half-stem-thickness))
3399            ;; Log for 1/8 is 3, so we need to subtract 3
3400            (flag-stencil (buildflags stencil (- log 3) stencil spacing)))
3401       flag-stencil))
3402
3403   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
3404                                                props)))
3405          (size-factor (magstep font-size))
3406          (blot (ly:output-def-lookup layout 'blot-diameter))
3407          (head-glyph-name
3408           (let ((result (get-glyph-name font
3409                                         (get-glyph-name-candidates
3410                                          (sign dir) log style))))
3411             (if (string-null? result)
3412                 ;; If no glyph name can be found, select default heads.
3413                 ;; Though this usually means an unsupported style has been
3414                 ;; chosen, it also prevents unrelated 'style settings from
3415                 ;; other grobs (e.g., TextSpanner and TimeSignature) leaking
3416                 ;; into markup.
3417                 (get-glyph-name font
3418                                 (get-glyph-name-candidates
3419                                  (sign dir) log 'default))
3420                 result)))
3421          (head-glyph (ly:font-get-glyph font head-glyph-name))
3422          (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural)))
3423          (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
3424          (stem-length (* size-factor (max 3 (- log 1))))
3425          ;; With ancient-flags we want a tighter stem
3426          (stem-thickness (* size-factor (if ancient-flags? 0.1 0.13)))
3427          (stemy (* dir stem-length))
3428          (attach-off (cons (interval-index
3429                             (ly:stencil-extent head-glyph X)
3430                             (* (sign dir) (car attach-indices)))
3431                            ;; fixme, this is inconsistent between X & Y.
3432                            (* (sign dir)
3433                               (interval-index
3434                                (ly:stencil-extent head-glyph Y)
3435                                (cdr attach-indices)))))
3436          ;; For a tighter stem (with ancient-flags) the stem-width has to be
3437          ;; adjusted.
3438          (stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0))
3439          (stem-glyph (and (> log 0)
3440                           (ly:round-filled-box
3441                            (ordered-cons (+ stem-X-corr (car attach-off))
3442                                          (+ stem-X-corr (car attach-off)
3443                                             (* (- (sign dir)) stem-thickness)))
3444                            (cons (min stemy (cdr attach-off))
3445                                  (max stemy (cdr attach-off)))
3446                            (/ stem-thickness 3))))
3447          (dot (ly:font-get-glyph font "dots.dot"))
3448          (dotwid (interval-length (ly:stencil-extent dot X)))
3449          (dots (and (> dot-count 0)
3450                     (apply ly:stencil-add
3451                            (map (lambda (x)
3452                                   (ly:stencil-translate-axis
3453                                    dot (* 2 x dotwid) X))
3454                                 (iota dot-count)))))
3455          ;; Straight-flags. Values taken from /scm/flag-style.scm
3456          (modern-straight-flag (straight-flag-mrkp 0.55 1 -18 1.1 22 1.2 dir))
3457          (old-straight-flag (straight-flag-mrkp 0.55 1 -45 1.2 45 1.4 dir))
3458          (flat-flag (straight-flag-mrkp 0.55 1.0 0 1.0 0 1.0 dir))
3459          ;; Calculate a corrective to avoid a gap between
3460          ;; straight-flags and the stem.
3461          (flag-style-Y-corr (if (or (eq? flag-style 'modern-straight-flag)
3462                                     (eq? flag-style 'old-straight-flag)
3463                                     (eq? flag-style 'flat-flag))
3464                                 (/ blot 10 (* -1 dir))
3465                                 0))
3466          (flaggl (and (> log 2)
3467                       (ly:stencil-translate
3468                        (cond ((eq? flag-style 'modern-straight-flag)
3469                               modern-straight-flag)
3470                              ((eq? flag-style 'old-straight-flag)
3471                               old-straight-flag)
3472                              ((eq? flag-style 'flat-flag)
3473                               flat-flag)
3474                              (else
3475                               (ly:font-get-glyph font
3476                                                  (format #f (if ancient-flags?
3477                                                                 "flags.mensural~a2~a"
3478                                                                 "flags.~a~a")
3479                                                          (if (> dir 0) "u" "d")
3480                                                          log))))
3481                        (cons (+ (car attach-off)
3482                                 ;; For tighter stems (with ancient-flags) the
3483                                 ;; flag has to be adjusted different.
3484                                 (if (and (not ancient-flags?) (< dir 0))
3485                                     stem-thickness
3486                                     0))
3487                              (+ stemy flag-style-Y-corr))))))
3488
3489     ;; If there is a flag on an upstem and the stem is short, move the dots
3490     ;; to avoid the flag.  16th notes get a special case because their flags
3491     ;; hang lower than any other flags.
3492     ;; Not with ancient flags or straight-flags.
3493     (if (and dots (> dir 0) (> log 2)
3494              (or (eq? flag-style 'default) (null? flag-style))
3495              (not ancient-flags?)
3496              (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
3497         (set! dots (ly:stencil-translate-axis dots 0.5 X)))
3498     (if flaggl
3499         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
3500     (if (ly:stencil? stem-glyph)
3501         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
3502         (set! stem-glyph head-glyph))
3503     (if (ly:stencil? dots)
3504         (set! stem-glyph
3505               (ly:stencil-add
3506                (ly:stencil-translate-axis
3507                 dots
3508                 (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
3509                 X)
3510                stem-glyph)))
3511     stem-glyph))
3512
3513 (define-public log2
3514   (let ((divisor (log 2)))
3515     (lambda (z) (inexact->exact (/ (log z) divisor)))))
3516
3517 (define (parse-simple-duration duration-string)
3518   "Parse the `duration-string', e.g. ''4..'' or ''breve.'',
3519 and return a (log dots) list."
3520   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)")
3521                             duration-string)))
3522     (if (and match (string=? duration-string (match:substring match 0)))
3523         (let ((len (match:substring match 1))
3524               (dots (match:substring match 2)))
3525           (list (cond ((string=? len "breve") -1)
3526                       ((string=? len "longa") -2)
3527                       ((string=? len "maxima") -3)
3528                       (else (log2 (string->number len))))
3529                 (if dots (string-length dots) 0)))
3530         (ly:error (_ "not a valid duration string: ~a") duration-string))))
3531
3532 (define-markup-command (note layout props duration dir)
3533   (string? number?)
3534   #:category music
3535   #:properties (note-by-number-markup)
3536   "
3537 @cindex notes within text by string
3538
3539 This produces a note with a stem pointing in @var{dir} direction, with
3540 the @var{duration} for the note head type and augmentation dots.  For
3541 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
3542 a shortened down stem.
3543
3544 @lilypond[verbatim,quote]
3545 \\markup {
3546   \\override #'(style . cross) {
3547     \\note #\"4..\" #UP
3548   }
3549   \\hspace #2
3550   \\note #\"breve\" #0
3551 }
3552 @end lilypond"
3553   (let ((parsed (parse-simple-duration duration)))
3554     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
3555
3556 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3557 ;; the rest command.
3558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3559
3560 (define-markup-command (rest-by-number layout props log dot-count)
3561   (number? number?)
3562   #:category music
3563   #:properties ((font-size 0)
3564                 (style '())
3565                 (multi-measure-rest #f))
3566   "
3567 @cindex rests or multi-measure-rests within text by log and dot-count
3568
3569 A rest or multi-measure-rest symbol.
3570
3571 @lilypond[verbatim,quote]
3572 \\markup {
3573   \\rest-by-number #3 #2
3574   \\hspace #2
3575   \\rest-by-number #0 #1
3576   \\hspace #2
3577   \\override #'(multi-measure-rest . #t)
3578   \\rest-by-number #0 #0
3579 }
3580 @end lilypond"
3581
3582   (define (get-glyph-name-candidates log style)
3583     (let* (;; Choose the style-string to be added.
3584            ;; If no glyph exists, select others for the specified styles
3585            ;; otherwise defaulting.
3586            (style-strg
3587             (cond (
3588                    ;; 'baroque needs to be special-cased, otherwise
3589                    ;; `select-head-glyph´ would catch neomensural-glyphs for
3590                    ;; this style, if (< log 0).
3591                    (eq? style 'baroque)
3592                    (string-append (number->string log) ""))
3593                   ((eq? style 'petrucci)
3594                    (string-append (number->string log) "mensural"))
3595                   ;; In other cases `select-head-glyph´ from output-lib.scm
3596                   ;; works for rest-glyphs, too.
3597                   ((and (symbol? style) (not (eq? style 'default)))
3598                    (select-head-glyph style log))
3599                   (else log)))
3600            ;; Choose ledgered glyphs for whole and half rest.
3601            ;; Except for the specified styles, logs and MultiMeasureRests.
3602            (ledger-style-rests
3603             (if (and (or (list? style)
3604                          (not (member style
3605                                       '(neomensural mensural petrucci))))
3606                      (not multi-measure-rest)
3607                      (or (= log 0) (= log 1)))
3608                 "o"
3609                 "")))
3610       (format #f "rests.~a~a" style-strg ledger-style-rests)))
3611
3612   (define (get-glyph-name font cands)
3613     (if (ly:stencil-empty? (ly:font-get-glyph font cands))
3614         ""
3615         cands))
3616
3617   (let* ((font
3618           (ly:paper-get-font layout
3619                              (cons '((font-encoding . fetaMusic)) props)))
3620          (rest-glyph-name
3621           (let ((result
3622                  (get-glyph-name font
3623                                  (get-glyph-name-candidates log style))))
3624             (if (string-null? result)
3625                 ;; If no glyph name can be found, select default rests.  Though
3626                 ;; this usually means an unsupported style has been chosen, it
3627                 ;; also prevents unrelated 'style settings from other grobs
3628                 ;; (e.g., TextSpanner and TimeSignature) leaking into markup.
3629                 (get-glyph-name font (get-glyph-name-candidates log 'default))
3630                 result)))
3631          (rest-glyph (ly:font-get-glyph font rest-glyph-name))
3632          (dot (ly:font-get-glyph font "dots.dot"))
3633          (dot-width (interval-length (ly:stencil-extent dot X)))
3634          (dots (and (> dot-count 0)
3635                     (apply ly:stencil-add
3636                            (map (lambda (x)
3637                                   (ly:stencil-translate-axis
3638                                    dot (* 2 x dot-width) X))
3639                                 (iota dot-count))))))
3640
3641     ;; Apart from mensural-, neomensural- and petrucci-style ledgered
3642     ;; glyphs are taken for whole and half rests.
3643     ;; If they are dotted, move the dots in X-direction to avoid collision.
3644     (if (and dots
3645              (< log 2)
3646              (>= log 0)
3647              (not (member style '(neomensural mensural petrucci))))
3648         (set! dots (ly:stencil-translate-axis dots dot-width X)))
3649
3650     ;; Add dots to the rest-glyph.
3651     ;;
3652     ;; Not sure how to vertical align dots.
3653     ;; For now the dots are centered for half, whole or longer rests.
3654     ;; Otherwise placed near the top of the rest.
3655     ;;
3656     ;; Dots for rests with (< log 0) dots are allowed, but not
3657     ;; if multi-measure-rest is set #t.
3658     (if (and (not multi-measure-rest) dots)
3659         (set! rest-glyph
3660               (ly:stencil-add
3661                (ly:stencil-translate
3662                 dots
3663                 (cons
3664                  (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width)
3665                  (if (< log 2)
3666                      (interval-center (ly:stencil-extent rest-glyph Y))
3667                      (- (interval-end (ly:stencil-extent rest-glyph Y))
3668                         (/ (* 2 dot-width) 3)))))
3669                rest-glyph)))
3670     rest-glyph))
3671
3672 (define-markup-command (rest layout props duration)
3673   (string?)
3674   #:category music
3675   #:properties ((style '())
3676                 (multi-measure-rest #f)
3677                 (multi-measure-rest-number #t)
3678                 (word-space 0.6))
3679   "
3680 @cindex rests or multi-measure-rests within text by string
3681
3682 This produces a rest, with the @var{duration} for the rest type and
3683 augmentation dots.
3684 @code{\"breve\"}, @code{\"longa\"} and @code{\"maxima\"} are valid
3685 input-strings.
3686
3687 Printing MultiMeasureRests could be enabled with
3688 @code{\\override #'(multi-measure-rest . #t)}
3689 If MultiMeasureRests are taken, the MultiMeasureRestNumber is printed above.
3690 This is enabled for all styles using default-glyphs.
3691 Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)}
3692
3693 @lilypond[verbatim,quote]
3694 \\markup {
3695   \\rest #\"4..\"
3696   \\hspace #2
3697   \\rest #\"breve\"
3698   \\hspace #2
3699   \\override #'(multi-measure-rest . #t)
3700   {
3701   \\rest #\"7\"
3702   \\hspace #2
3703   \\override #'(multi-measure-rest-number . #f)
3704   \\rest #\"7\"
3705   }
3706 }
3707 @end lilypond"
3708   ;; Get the number of mmr-glyphs.
3709   ;; Store them in a list.
3710   ;; example: (mmr-numbers 25) -> '(3 0 0 1)
3711   (define (mmr-numbers nmbr)
3712     (let* ((8-bar-glyph (floor (/ nmbr 8)))
3713            (8-remainder (remainder nmbr 8))
3714            (4-bar-glyph (floor (/ 8-remainder 4)))
3715            (4-remainder (remainder nmbr 4))
3716            (2-bar-glyph (floor (/ 4-remainder 2)))
3717            (2-remainder (remainder 4-remainder 2))
3718            (1-bar-glyph (floor (/ 2-remainder 1))))
3719       (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph)))
3720
3721   ;; Get the correct mmr-glyphs.
3722   ;; Store them in a list.
3723   ;; example:
3724   ;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0"))
3725   ;; -> ("rests.M3" "rests.M1")
3726   (define (get-mmr-glyphs lst1 lst2)
3727     (define (helper l1 l2 l3)
3728       (if (null? l1)
3729           (reverse l3)
3730           (helper (cdr l1)
3731                   (cdr l2)
3732                   (append (make-list (car l1) (car l2)) l3))))
3733     (helper lst1 lst2 '()))
3734
3735   ;; If duration is not valid, print a warning and return empty-stencil
3736   (if (or (and (not (integer? (car (parse-simple-duration duration))))
3737                (not multi-measure-rest))
3738           (and (= (string-length (car (string-split duration #\. ))) 1)
3739                (= (string->number (car (string-split duration #\. ))) 0)))
3740       (begin
3741         (ly:warning (_ "not a valid duration string: ~a - ignoring") duration)
3742         empty-stencil)
3743       (let* (
3744              ;; For simple rests:
3745              ;; Get a (log dots) list.
3746              (parsed (parse-simple-duration duration))
3747              ;; Create the rest-stencil
3748              (stil
3749               (rest-by-number-markup layout props (car parsed) (cadr parsed)))
3750              ;; For MultiMeasureRests:
3751              ;; Get the duration-part of duration
3752              (dur-part-string (car (string-split duration #\. )))
3753              ;; Get the duration of MMR:
3754              ;; If not a number (eg. "maxima") calculate it.
3755              (mmr-duration
3756               (or (string->number dur-part-string) (expt 2 (abs (car parsed)))))
3757              ;; Get a list of the correct number of each mmr-glyph.
3758              (count-mmr-glyphs-list (mmr-numbers mmr-duration))
3759              ;; Create a list of mmr-stencils,
3760              ;; translating the glyph for a whole rest.
3761              (mmr-stils-list
3762               (map
3763                (lambda (x)
3764                  (let ((single-mmr-stil
3765                         (rest-by-number-markup layout props (* -1 x) 0)))
3766                    (if (= x 0)
3767                        (ly:stencil-translate-axis
3768                         single-mmr-stil
3769                         ;; Ugh, hard-coded, why 1?
3770                         1
3771                         Y)
3772                        single-mmr-stil)))
3773                (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4)))))
3774              ;; Adjust the space between the mmr-glyphs,
3775              ;; if not default-glyphs are used.
3776              (word-space (if (member style
3777                                      '(neomensural mensural petrucci))
3778                              (/ (* word-space 2) 3)
3779                              word-space))
3780              ;; Create the final mmr-stencil
3781              ;; via `stack-stencil-line´ from /scm/markup.scm
3782              (mmr-stil (stack-stencil-line word-space mmr-stils-list)))
3783
3784         ;; Print the number above a multi-measure-rest
3785         ;; Depends on duration, style and multi-measure-rest-number set #t
3786         (if (and multi-measure-rest
3787                  multi-measure-rest-number
3788                  (> mmr-duration 1)
3789                  (not (member style '(neomensural mensural petrucci))))
3790             (let* ((mmr-stil-x-center
3791                     (interval-center (ly:stencil-extent mmr-stil X)))
3792                    (duration-markup
3793                     (markup
3794                      #:fontsize -2
3795                      #:override '(font-encoding . fetaText)
3796                      (number->string mmr-duration)))
3797                    (mmr-number-stil
3798                     (interpret-markup layout props duration-markup))
3799                    (mmr-number-stil-x-center
3800                     (interval-center (ly:stencil-extent mmr-number-stil X))))
3801
3802               (set! mmr-stil (ly:stencil-combine-at-edge
3803                               mmr-stil
3804                               Y UP
3805                               (ly:stencil-translate-axis
3806                                mmr-number-stil
3807                                (- mmr-stil-x-center mmr-number-stil-x-center)
3808                                X)
3809                               ;; Ugh, hardcoded
3810                               0.8))))
3811         (if multi-measure-rest
3812             mmr-stil
3813             stil))))
3814
3815 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3816 ;; fermata markup
3817 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3818
3819 (define-markup-command (fermata layout props) ()
3820   #:category music
3821   #:properties ((direction UP))
3822   "Create a fermata glyph.  When @var{direction} is @code{DOWN}, use
3823 an inverted glyph.  Note that within music, one would usually use the
3824 @code{\\fermata} articulation instead of a markup.
3825
3826 @lilypond[verbatim,quote]
3827  { c1^\\markup \\fermata d1_\\markup \\fermata }
3828
3829 \\markup { \\fermata \\override #`(direction . ,DOWN) \\fermata }
3830 @end lilypond
3831 "
3832   (interpret-markup layout props
3833                     (if (eqv? direction DOWN)
3834                         (markup #:musicglyph "scripts.dfermata")
3835                         (markup #:musicglyph "scripts.ufermata"))))
3836
3837 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3838 ;; translating.
3839 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3840
3841 (define-markup-command (lower layout props amount arg)
3842   (number? markup?)
3843   #:category align
3844   "
3845 @cindex lowering text
3846
3847 Lower @var{arg} by the distance @var{amount}.
3848 A negative @var{amount} indicates raising; see also @code{\\raise}.
3849
3850 @lilypond[verbatim,quote]
3851 \\markup {
3852   one
3853   \\lower #3
3854   two
3855   three
3856 }
3857 @end lilypond"
3858   (ly:stencil-translate-axis (interpret-markup layout props arg)
3859                              (- amount) Y))
3860
3861 (define-markup-command (translate-scaled layout props offset arg)
3862   (number-pair? markup?)
3863   #:category align
3864   #:properties ((font-size 0))
3865   "
3866 @cindex translating text
3867 @cindex scaling text
3868
3869 Translate @var{arg} by @var{offset}, scaling the offset by the
3870 @code{font-size}.
3871
3872 @lilypond[verbatim,quote]
3873 \\markup {
3874   \\fontsize #5 {
3875     * \\translate #'(2 . 3) translate
3876     \\hspace #2
3877     * \\translate-scaled #'(2 . 3) translate-scaled
3878   }
3879 }
3880 @end lilypond"
3881   (let* ((factor (magstep font-size))
3882          (scaled (cons (* factor (car offset))
3883                        (* factor (cdr offset)))))
3884     (ly:stencil-translate (interpret-markup layout props arg)
3885                           scaled)))
3886
3887 (define-markup-command (raise layout props amount arg)
3888   (number? markup?)
3889   #:category align
3890   "
3891 @cindex raising text
3892
3893 Raise @var{arg} by the distance @var{amount}.
3894 A negative @var{amount} indicates lowering, see also @code{\\lower}.
3895
3896 The argument to @code{\\raise} is the vertical displacement amount,
3897 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
3898 raise objects in relation to their surrounding markups.
3899
3900 If the text object itself is positioned above or below the staff, then
3901 @code{\\raise} cannot be used to move it, since the mechanism that
3902 positions it next to the staff cancels any shift made with
3903 @code{\\raise}.  For vertical positioning, use the @code{padding}
3904 and/or @code{extra-offset} properties.
3905
3906 @lilypond[verbatim,quote]
3907 \\markup {
3908   C
3909   \\small
3910   \\bold
3911   \\raise #1.0
3912   9/7+
3913 }
3914 @end lilypond"
3915   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
3916
3917 (define-markup-command (fraction layout props arg1 arg2)
3918   (markup? markup?)
3919   #:category other
3920   #:properties ((font-size 0))
3921   "
3922 @cindex creating text fractions
3923
3924 Make a fraction of two markups.
3925 @lilypond[verbatim,quote]
3926 \\markup {
3927   π ≈
3928   \\fraction 355 113
3929 }
3930 @end lilypond"
3931   (let* ((m1 (interpret-markup layout props arg1))
3932          (m2 (interpret-markup layout props arg2))
3933          (factor (magstep font-size))
3934          (boxdimen (cons (* factor -0.05) (* factor 0.05)))
3935          (padding (* factor 0.2))
3936          (baseline (* factor 0.6))
3937          (offset (* factor 0.75)))
3938     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
3939     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
3940     (let* ((x1 (ly:stencil-extent m1 X))
3941            (x2 (ly:stencil-extent m2 X))
3942            (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
3943            ;; should stack mols separately, to maintain LINE on baseline
3944            (stack (stack-lines DOWN padding baseline (list m1 line m2))))
3945       (set! stack
3946             (ly:stencil-aligned-to stack Y CENTER))
3947       (set! stack
3948             (ly:stencil-aligned-to stack X LEFT))
3949       ;; should have EX dimension
3950       ;; empirical anyway
3951       (ly:stencil-translate-axis stack offset Y))))
3952
3953 (define-markup-command (normal-size-super layout props arg)
3954   (markup?)
3955   #:category font
3956   #:properties ((baseline-skip))
3957   "
3958 @cindex setting superscript in standard font size
3959
3960 Set @var{arg} in superscript with a normal font size.
3961
3962 @lilypond[verbatim,quote]
3963 \\markup {
3964   default
3965   \\normal-size-super {
3966     superscript in standard size
3967   }
3968 }
3969 @end lilypond"
3970   (ly:stencil-translate-axis
3971    (interpret-markup layout props arg)
3972    (* 0.5 baseline-skip) Y))
3973
3974 (define-markup-command (super layout props arg)
3975   (markup?)
3976   #:category font
3977   #:properties ((font-size 0)
3978                 (baseline-skip))
3979   "
3980 @cindex superscript text
3981
3982 Set @var{arg} in superscript.
3983
3984 @lilypond[verbatim,quote]
3985 \\markup {
3986   E =
3987   \\concat {
3988     mc
3989     \\super
3990     2
3991   }
3992 }
3993 @end lilypond"
3994   (ly:stencil-translate-axis
3995    (interpret-markup
3996     layout
3997     (cons `((font-size . ,(- font-size 3))) props)
3998     arg)
3999    (* 0.5 baseline-skip)
4000    Y))
4001
4002 (define-markup-command (translate layout props offset arg)
4003   (number-pair? markup?)
4004   #:category align
4005   "
4006 @cindex translating text
4007
4008 Translate @var{arg} relative to its surroundings.  @var{offset}
4009 is a pair of numbers representing the displacement in the X and Y axis.
4010
4011 @lilypond[verbatim,quote]
4012 \\markup {
4013   *
4014   \\translate #'(2 . 3)
4015   \\line { translated two spaces right, three up }
4016 }
4017 @end lilypond"
4018   (ly:stencil-translate (interpret-markup layout props arg)
4019                         offset))
4020
4021 (define-markup-command (sub layout props arg)
4022   (markup?)
4023   #:category font
4024   #:properties ((font-size 0)
4025                 (baseline-skip))
4026   "
4027 @cindex subscript text
4028
4029 Set @var{arg} in subscript.
4030
4031 @lilypond[verbatim,quote]
4032 \\markup {
4033   \\concat {
4034     H
4035     \\sub {
4036       2
4037     }
4038     O
4039   }
4040 }
4041 @end lilypond"
4042   (ly:stencil-translate-axis
4043    (interpret-markup
4044     layout
4045     (cons `((font-size . ,(- font-size 3))) props)
4046     arg)
4047    (* -0.5 baseline-skip)
4048    Y))
4049
4050 (define-markup-command (normal-size-sub layout props arg)
4051   (markup?)
4052   #:category font
4053   #:properties ((baseline-skip))
4054   "
4055 @cindex setting subscript in standard font size
4056
4057 Set @var{arg} in subscript with a normal font size.
4058
4059 @lilypond[verbatim,quote]
4060 \\markup {
4061   default
4062   \\normal-size-sub {
4063     subscript in standard size
4064   }
4065 }
4066 @end lilypond"
4067   (ly:stencil-translate-axis
4068    (interpret-markup layout props arg)
4069    (* -0.5 baseline-skip)
4070    Y))
4071
4072 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4073 ;; brackets.
4074 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4075
4076 (define-markup-command (hbracket layout props arg)
4077   (markup?)
4078   #:category graphic
4079   "
4080 @cindex placing horizontal brackets around text
4081
4082 Draw horizontal brackets around @var{arg}.
4083
4084 @lilypond[verbatim,quote]
4085 \\markup {
4086   \\hbracket {
4087     \\line {
4088       one two three
4089     }
4090   }
4091 }
4092 @end lilypond"
4093   (let ((th 0.1) ;; todo: take from GROB.
4094         (m (interpret-markup layout props arg)))
4095     (bracketify-stencil m X th (* 2.5 th) th)))
4096
4097 (define-markup-command (bracket layout props arg)
4098   (markup?)
4099   #:category graphic
4100   "
4101 @cindex placing vertical brackets around text
4102
4103 Draw vertical brackets around @var{arg}.
4104
4105 @lilypond[verbatim,quote]
4106 \\markup {
4107   \\bracket {
4108     \\note #\"2.\" #UP
4109   }
4110 }
4111 @end lilypond"
4112   (let ((th 0.1) ;; todo: take from GROB.
4113         (m (interpret-markup layout props arg)))
4114     (bracketify-stencil m Y th (* 2.5 th) th)))
4115
4116 (define-markup-command (parenthesize layout props arg)
4117   (markup?)
4118   #:category graphic
4119   #:properties ((angularity 0)
4120                 (padding)
4121                 (size 1)
4122                 (thickness 1)
4123                 (width 0.25))
4124   "
4125 @cindex placing parentheses around text
4126
4127 Draw parentheses around @var{arg}.  This is useful for parenthesizing
4128 a column containing several lines of text.
4129
4130 @lilypond[verbatim,quote]
4131 \\markup {
4132   \\line {
4133     \\parenthesize {
4134       \\column {
4135         foo
4136         bar
4137       }
4138     }
4139     \\override #'(angularity . 2) {
4140       \\parenthesize {
4141         \\column {
4142           bah
4143           baz
4144         }
4145       }
4146     }
4147   }
4148 }
4149 @end lilypond"
4150   (let* ((markup (interpret-markup layout props arg))
4151          (scaled-width (* size width))
4152          (scaled-thickness
4153           (* (chain-assoc-get 'line-thickness props 0.1)
4154              thickness))
4155          (half-thickness
4156           (min (* size 0.5 scaled-thickness)
4157                (* (/ 4 3.0) scaled-width)))
4158          (padding (chain-assoc-get 'padding props half-thickness)))
4159     (parenthesize-stencil
4160      markup half-thickness scaled-width angularity padding)))
4161
4162
4163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4164 ;; Delayed markup evaluation
4165 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4166
4167 (define-markup-command (page-ref layout props label gauge default)
4168   (symbol? markup? markup?)
4169   #:category other
4170   "
4171 @cindex referencing page numbers in text
4172
4173 Reference to a page number.  @var{label} is the label set on the referenced
4174 page (using the @code{\\label} command), @var{gauge} a markup used to estimate
4175 the maximum width of the page number, and @var{default} the value to display
4176 when @var{label} is not found."
4177   (let* ((gauge-stencil (interpret-markup layout props gauge))
4178          (x-ext (ly:stencil-extent gauge-stencil X))
4179          (y-ext (ly:stencil-extent gauge-stencil Y)))
4180    (ly:stencil-add
4181     (make-transparent-box-stencil x-ext y-ext))
4182     (ly:make-stencil
4183      `(delay-stencil-evaluation
4184        ,(delay (ly:stencil-expr
4185                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
4186                        (page-number (if (list? table)
4187                                         (assoc-get label table)
4188                                         #f))
4189                        (page-markup (if page-number (format #f "~a" page-number) default))
4190                        (page-stencil (interpret-markup layout props page-markup))
4191                        (gap (- (interval-length x-ext)
4192                                (interval-length (ly:stencil-extent page-stencil X)))))
4193                   (interpret-markup layout props
4194                                     (markup #:hspace gap page-markup))))))
4195      x-ext
4196      y-ext)))
4197
4198 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4199 ;; scaling
4200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4201
4202 (define-markup-command (scale layout props factor-pair arg)
4203   (number-pair? markup?)
4204   #:category graphic
4205   "
4206 @cindex scaling markup
4207 @cindex mirroring markup
4208
4209 Scale @var{arg}.  @var{factor-pair} is a pair of numbers
4210 representing the scaling-factor in the X and Y axes.
4211 Negative values may be used to produce mirror images.
4212
4213 @lilypond[verbatim,quote]
4214 \\markup {
4215   \\line {
4216     \\scale #'(2 . 1)
4217     stretched
4218     \\scale #'(1 . -1)
4219     mirrored
4220   }
4221 }
4222 @end lilypond"
4223   (let ((stil (interpret-markup layout props arg))
4224         (sx (car factor-pair))
4225         (sy (cdr factor-pair)))
4226     (ly:stencil-scale stil sx sy)))
4227
4228 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4229 ;; Repeating
4230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4231
4232 (define-markup-command (pattern layout props count axis space pattern)
4233   (integer? integer? number? markup?)
4234   #:category other
4235   "
4236 Prints @var{count} times a @var{pattern} markup.
4237 Patterns are spaced apart by @var{space}.
4238 Patterns are distributed on @var{axis}.
4239
4240 @lilypond[verbatim, quote]
4241 \\markup \\column {
4242   \"Horizontally repeated :\"
4243   \\pattern #7 #X #2 \\flat
4244   \\null
4245   \"Vertically repeated :\"
4246   \\pattern #3 #Y #0.5 \\flat
4247 }
4248 @end lilypond"
4249   (let ((pattern-width (interval-length
4250                         (ly:stencil-extent (interpret-markup layout props pattern) X)))
4251         (new-props (prepend-alist-chain 'word-space 0 (prepend-alist-chain 'baseline-skip 0 props))))
4252     (let loop ((i (1- count)) (patterns (markup)))
4253       (if (zero? i)
4254           (interpret-markup
4255            layout
4256            new-props
4257            (if (= axis X)
4258                (markup patterns pattern)
4259                (markup #:column (patterns pattern))))
4260           (loop (1- i)
4261                 (if (= axis X)
4262                     (markup patterns pattern #:hspace space)
4263                     (markup #:column (patterns pattern #:vspace space))))))))
4264
4265 (define-markup-command (fill-with-pattern layout props space dir pattern left right)
4266   (number? ly:dir? markup? markup? markup?)
4267   #:category align
4268   #:properties ((word-space)
4269                 (line-width))
4270   "
4271 Put @var{left} and @var{right} in a horizontal line of width @code{line-width}
4272 with a line of markups @var{pattern} in between.
4273 Patterns are spaced apart by @var{space}.
4274 Patterns are aligned to the @var{dir} markup.
4275
4276 @lilypond[verbatim, quote]
4277 \\markup \\column {
4278   \"right-aligned :\"
4279   \\fill-with-pattern #1 #RIGHT . first right
4280   \\fill-with-pattern #1 #RIGHT . second right
4281   \\null
4282   \"center-aligned :\"
4283   \\fill-with-pattern #1.5 #CENTER - left right
4284   \\null
4285   \"left-aligned :\"
4286   \\override #'(line-width . 50)
4287   \\fill-with-pattern #2 #LEFT : left first
4288   \\override #'(line-width . 50)
4289   \\fill-with-pattern #2 #LEFT : left second
4290 }
4291 @end lilypond"
4292   (let* ((pattern-x-extent (ly:stencil-extent (interpret-markup layout props pattern) X))
4293          (pattern-width (interval-length pattern-x-extent))
4294          (left-width (interval-length (ly:stencil-extent (interpret-markup layout props left) X)))
4295          (right-width (interval-length (ly:stencil-extent (interpret-markup layout props right) X)))
4296          (middle-width (max 0 (- line-width (+ (+ left-width right-width) (* word-space 2)))))
4297          (period (+ space pattern-width))
4298          (count (truncate (/ (- middle-width pattern-width) period)))
4299          (x-offset (+ (* (- (- middle-width (* count period)) pattern-width) (/ (1+ dir) 2)) (abs (car pattern-x-extent)))))
4300     (interpret-markup layout props
4301                       (markup left
4302                               #:with-dimensions (cons 0 middle-width) '(0 . 0)
4303                               #:translate (cons x-offset 0)
4304                               #:pattern (1+ count) X space pattern
4305                               right))))
4306
4307 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4308 ;; Replacements
4309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4310
4311 (define-markup-command (replace layout props replacements arg)
4312   (list? markup?)
4313   #:category font
4314   "
4315 Used to automatically replace a string by another in the markup @var{arg}.
4316 Each pair of the alist @var{replacements} specifies what should be replaced.
4317 The @code{key} is the string to be replaced by the @code{value} string.
4318
4319 @lilypond[verbatim, quote]
4320 \\markup \\replace #'((\"thx\" . \"Thanks!\")) thx
4321 @end lilypond"
4322   (interpret-markup
4323    layout
4324    (internal-add-text-replacements
4325     props
4326     replacements)
4327    (markup arg)))
4328
4329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4330 ;; Markup list commands
4331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4332
4333 (define-public (space-lines baseline stils)
4334   (let space-stil ((stils stils)
4335                    (result (list)))
4336     (if (null? stils)
4337         (reverse! result)
4338         (let* ((stil (car stils))
4339                (dy-top (max (- (/ baseline 1.5)
4340                                (interval-bound (ly:stencil-extent stil Y) UP))
4341                             0.0))
4342                (dy-bottom (max (+ (/ baseline 3.0)
4343                                   (interval-bound (ly:stencil-extent stil Y) DOWN))
4344                                0.0))
4345                (new-stil (ly:make-stencil
4346                           (ly:stencil-expr stil)
4347                           (ly:stencil-extent stil X)
4348                           (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN)
4349                                    dy-bottom)
4350                                 (+ (interval-bound (ly:stencil-extent stil Y) UP)
4351                                    dy-top)))))
4352           (space-stil (cdr stils) (cons new-stil result))))))
4353
4354 (define-markup-list-command (justified-lines layout props args)
4355   (markup-list?)
4356   #:properties ((baseline-skip)
4357                 wordwrap-internal-markup-list)
4358   "
4359 @cindex justifying lines of text
4360
4361 Like @code{\\justify}, but return a list of lines instead of a single markup.
4362 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
4363 @var{X}@tie{}is the number of staff spaces."
4364   (space-lines baseline-skip
4365                (interpret-markup-list layout props
4366                                       (make-wordwrap-internal-markup-list #t args))))
4367
4368 (define-markup-list-command (wordwrap-lines layout props args)
4369   (markup-list?)
4370   #:properties ((baseline-skip)
4371                 wordwrap-internal-markup-list)
4372   "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
4373 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
4374 where @var{X} is the number of staff spaces."
4375   (space-lines baseline-skip
4376                (interpret-markup-list layout props
4377                                       (make-wordwrap-internal-markup-list #f args))))
4378
4379 (define-markup-list-command (column-lines layout props args)
4380   (markup-list?)
4381   #:properties ((baseline-skip))
4382   "Like @code{\\column}, but return a list of lines instead of a single markup.
4383 @code{baseline-skip} determines the space between each markup in @var{args}."
4384   (space-lines baseline-skip
4385                (interpret-markup-list layout props args)))
4386
4387 (define-markup-list-command (override-lines layout props new-prop args)
4388   (pair? markup-list?)
4389   "Like @code{\\override}, for markup lists."
4390   (interpret-markup-list layout (cons (list new-prop) props) args))
4391
4392 (define-markup-list-command (map-markup-commands layout props compose args)
4393   (procedure? markup-list?)
4394   "This applies the function @var{compose} to every markup in
4395 @var{args} (including elements of markup list command calls) in order
4396 to produce a new markup list.  Since the return value from a markup
4397 list command call is not a markup list but rather a list of stencils,
4398 this requires passing those stencils off as the results of individual
4399 markup calls.  That way, the results should work out as long as no
4400 markups rely on side effects."
4401   (let ((key (make-symbol "key")))
4402     (catch
4403      key
4404      (lambda ()
4405        ;; if `compose' does not actually interpret its markup
4406        ;; argument, we still need to return a list of stencils,
4407        ;; created from the single returned stencil
4408        (list
4409         (interpret-markup layout props
4410                           (compose
4411                            (make-on-the-fly-markup
4412                             (lambda (layout props m)
4413                               ;; here all effects of `compose' on the
4414                               ;; properties should be visible, so we
4415                               ;; call interpret-markup-list at this
4416                               ;; point of time and harvest its
4417                               ;; stencils
4418                               (throw key
4419                                      (interpret-markup-list
4420                                       layout props args)))
4421                             (make-null-markup))))))
4422      (lambda (key stencils)
4423        (map
4424         (lambda (sten)
4425           (interpret-markup layout props
4426                             (compose (make-stencil-markup sten))))
4427         stencils)))))