scm/define-markup-commands.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2014  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-list-command (score-lines layout props score)
1020   (ly:score?)
1021   "This is the same as the @code{\\score} markup but delivers its
1022 systems as a list of lines.  Its @var{score} argument is entered in
1023 braces like it would be for @code{\\score}."
1024   (let ((output (ly:score-embedded-format score layout)))
1025
1026     (if (ly:music-output? output)
1027         (map
1028          (lambda (paper-system)
1029            ;; shift such that the refpoint of the bottom staff of
1030            ;; the first system is the baseline of the score
1031            (ly:stencil-translate-axis
1032             (paper-system-stencil paper-system)
1033             (- (car (paper-system-staff-extents paper-system)))
1034             Y))
1035          (vector->list (ly:paper-score-paper-systems output)))
1036         (begin
1037           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
1038           '()))))
1039
1040 (define-markup-command (score layout props score)
1041   (ly:score?)
1042   #:category music
1043   #:properties ((baseline-skip))
1044   "
1045 @cindex inserting music into text
1046
1047 Inline an image of music.  The reference point (usually the middle
1048 staff line) of the lowest staff in the top system is placed on the
1049 baseline.
1050
1051 @lilypond[verbatim,quote]
1052 \\markup {
1053   \\score {
1054     \\new PianoStaff <<
1055       \\new Staff \\relative c' {
1056         \\key f \\major
1057         \\time 3/4
1058         \\mark \\markup { Allegro }
1059         f2\\p( a4)
1060         c2( a4)
1061         bes2( g'4)
1062         f8( e) e4 r
1063       }
1064       \\new Staff \\relative c {
1065         \\clef bass
1066         \\key f \\major
1067         \\time 3/4
1068         f8( a c a c a
1069         f c' es c es c)
1070         f,( bes d bes d bes)
1071         f( g bes g bes g)
1072       }
1073     >>
1074     \\layout {
1075       indent = 0.0\\cm
1076       \\context {
1077         \\Score
1078         \\override RehearsalMark
1079           #'break-align-symbols = #'(time-signature key-signature)
1080         \\override RehearsalMark
1081           #'self-alignment-X = #LEFT
1082       }
1083       \\context {
1084         \\Staff
1085         \\override TimeSignature
1086           #'break-align-anchor-alignment = #LEFT
1087       }
1088     }
1089   }
1090 }
1091 @end lilypond"
1092   (stack-stencils Y DOWN baseline-skip
1093                   (score-lines-markup-list layout props score)))
1094
1095 (define-markup-command (null layout props)
1096   ()
1097   #:category other
1098   "
1099 @cindex creating empty text objects
1100
1101 An empty markup with extents of a single point.
1102
1103 @lilypond[verbatim,quote]
1104 \\markup {
1105   \\null
1106 }
1107 @end lilypond"
1108   point-stencil)
1109
1110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1111 ;; basic formatting.
1112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1113
1114 (define-markup-command (simple layout props str)
1115   (string?)
1116   #:category font
1117   "
1118 @cindex simple text strings
1119
1120 A simple text string; @code{\\markup @{ foo @}} is equivalent with
1121 @code{\\markup @{ \\simple #\"foo\" @}}.
1122
1123 Note: for creating standard text markup or defining new markup commands,
1124 the use of @code{\\simple} is unnecessary.
1125
1126 @lilypond[verbatim,quote]
1127 \\markup {
1128   \\simple #\"simple\"
1129   \\simple #\"text\"
1130   \\simple #\"strings\"
1131 }
1132 @end lilypond"
1133   (interpret-markup layout props str))
1134
1135 (define-markup-command (tied-lyric layout props str)
1136   (string?)
1137   #:category music
1138   #:properties ((word-space))
1139   "
1140 @cindex simple text strings with tie characters
1141
1142 Like simple-markup, but use tie characters for @q{~} tilde symbols.
1143
1144 @lilypond[verbatim,quote]
1145 \\markup \\column {
1146   \\tied-lyric #\"Siam navi~all'onde~algenti Lasciate~in abbandono\"
1147   \\tied-lyric #\"Impetuosi venti I nostri~affetti sono\"
1148   \\tied-lyric #\"Ogni diletto~e scoglio Tutta la vita~e~un mar.\"
1149 }
1150 @end lilypond"
1151   (define (replace-ties tie str)
1152     (if (string-contains str "~")
1153         (let*
1154             ((half-space (/ word-space 2))
1155              (parts (string-split str #\~))
1156              (tie-str (markup #:hspace half-space
1157                               #:musicglyph tie
1158                               #:hspace half-space))
1159              (joined  (list-join parts tie-str)))
1160           (make-concat-markup joined))
1161         str))
1162
1163   (define short-tie-regexp (make-regexp "~[^.]~"))
1164   (define (match-short str) (regexp-exec short-tie-regexp str))
1165
1166   (define (replace-short str mkp)
1167     (let ((match (match-short str)))
1168       (if (not match)
1169           (make-concat-markup (list
1170                                mkp
1171                                (replace-ties "ties.lyric.default" str)))
1172           (let ((new-str (match:suffix match))
1173                 (new-mkp (make-concat-markup (list
1174                                               mkp
1175                                               (replace-ties "ties.lyric.default"
1176                                                             (match:prefix match))
1177                                               (replace-ties "ties.lyric.short"
1178                                                             (match:substring match))))))
1179             (replace-short new-str new-mkp)))))
1180
1181   (interpret-markup layout
1182                     props
1183                     (replace-short str (markup))))
1184
1185 (define-public empty-markup
1186   (make-simple-markup ""))
1187
1188 ;; helper for justifying lines.
1189 (define (get-fill-space
1190           word-count line-width word-space text-widths constant-space?)
1191   "Calculate the necessary paddings between adjacent texts in a
1192 single justified line.  The lengths of all texts are stored in
1193 @var{text-widths}.
1194 When @var{constant-space?} is @code{#t}, the formula for the padding
1195 between texts is:
1196 padding = (line-width - total-text-width)/(word-count - 1)
1197 When @var{constant-space?} is @code{#f}, the formula for the
1198 padding between interior texts a and b is:
1199 padding = line-width/(word-count - 1) - (length(a) + length(b))/2
1200 In this case, the first and last padding have to be calculated
1201 specially using the whole length of the first or last text.
1202 All paddings are checked to be at least word-space, to ensure that
1203 no texts collide.
1204 Return a list of paddings."
1205   (cond
1206     ((null? text-widths) '())
1207     (constant-space?
1208      (make-list
1209        (1- word-count)
1210        ;; Ensure that space between words cannot be
1211        ;; less than word-space.
1212        (max
1213          word-space
1214          (/ (- line-width (apply + text-widths))
1215             (1- word-count)))))
1216
1217     ;; special case first padding
1218     ((= (length text-widths) word-count)
1219      (cons
1220        (- (- (/ line-width (1- word-count)) (car text-widths))
1221           (/ (cadr text-widths) 2))
1222        (get-fill-space
1223          word-count line-width word-space (cdr text-widths)
1224                                           constant-space?)))
1225     ;; special case last padding
1226     ((= (length text-widths) 2)
1227      (list (- (/ line-width (1- word-count))
1228               (+ (/ (car text-widths) 2) (cadr text-widths)))
1229            0))
1230     (else
1231       (let ((default-padding
1232               (- (/ line-width (1- word-count))
1233                  (/ (+ (car text-widths) (cadr text-widths)) 2))))
1234         (cons
1235           (if (> word-space default-padding)
1236               word-space
1237               default-padding)
1238           (get-fill-space
1239             word-count line-width word-space (cdr text-widths)
1240                                              constant-space?))))))
1241
1242 (define (justify-line-helper
1243           layout props args text-direction word-space line-width constant-space?)
1244   "Return a stencil which spreads @var{args} along a line of width
1245 @var{line-width}.  If @var{constant-space?} is set to @code{#t}, the
1246 space between words is constant.  If @code{#f}, the distance between
1247 words varies according to their relative lengths."
1248   (let* ((orig-stencils (interpret-markup-list layout props args))
1249          (stencils
1250            (map (lambda (stc)
1251                   (if (ly:stencil-empty? stc X)
1252                       (ly:make-stencil (ly:stencil-expr stc)
1253                                        '(0 . 0) (ly:stencil-extent stc Y))
1254                       stc))
1255                 orig-stencils))
1256          (text-widths
1257            (map (lambda (stc)
1258                   (if (ly:stencil-empty? stc)
1259                       0.0
1260                       (interval-length (ly:stencil-extent stc X))))
1261                 stencils))
1262          (text-width (apply + text-widths))
1263          (word-count (length stencils))
1264          (line-width (or line-width (ly:output-def-lookup layout 'line-width)))
1265          (fill-space
1266            (cond
1267              ((= word-count 1)
1268               (list
1269                 (/ (- line-width text-width) 2)
1270                 (/ (- line-width text-width) 2)))
1271              ((= word-count 2)
1272               (list
1273                 (- line-width text-width)))
1274              (else
1275                (get-fill-space
1276                  word-count line-width word-space text-widths
1277                                                   constant-space?))))
1278          (line-contents (if (= word-count 1)
1279                             (list
1280                               point-stencil
1281                               (car stencils)
1282                               point-stencil)
1283                             stencils)))
1284
1285     (if (null? (remove ly:stencil-empty? orig-stencils))
1286         empty-stencil
1287         (begin
1288           (if (= text-direction LEFT)
1289               (set! line-contents (reverse line-contents)))
1290           (set! line-contents
1291                 (stack-stencils-padding-list
1292                   X RIGHT fill-space line-contents))
1293           (if (> word-count 1)
1294               ;; shift s.t. stencils align on the left edge, even if
1295               ;; first stencil had negative X-extent (e.g. center-column)
1296               ;; (if word-count = 1, X-extents are already normalized in
1297               ;; the definition of line-contents)
1298               (set! line-contents
1299                     (ly:stencil-translate-axis
1300                       line-contents
1301                       (- (car (ly:stencil-extent (car stencils) X)))
1302                       X)))
1303           line-contents))))
1304
1305 (define-markup-command (fill-line layout props args)
1306   (markup-list?)
1307   #:category align
1308   #:properties ((text-direction RIGHT)
1309                 (word-space 0.6)
1310                 (line-width #f))
1311   "Put @var{markups} in a horizontal line of width @var{line-width}.
1312 The markups are spaced or flushed to fill the entire line.
1313 If there are no arguments, return an empty stencil.
1314
1315 @lilypond[verbatim,quote]
1316 \\markup {
1317   \\column {
1318     \\fill-line {
1319       Words evenly spaced across the page
1320     }
1321     \\null
1322     \\fill-line {
1323       \\line { Text markups }
1324       \\line {
1325         \\italic { evenly spaced }
1326       }
1327       \\line { across the page }
1328     }
1329   }
1330 }
1331 @end lilypond"
1332   (justify-line-helper
1333     layout props args text-direction word-space line-width #f))
1334
1335 (define-markup-command (justify-line layout props args)
1336   (markup-list?)
1337   #:category align
1338   #:properties ((text-direction RIGHT)
1339                 (word-space 0.6)
1340                 (line-width #f))
1341   "Put @var{markups} in a horizontal line of width @var{line-width}.
1342 The markups are spread to fill the entire line and separated by equal
1343 space.  If there are no arguments, return an empty stencil.
1344
1345 @lilypond[verbatim,quote]
1346 \\markup {
1347   \\justify-line {
1348     Space between neighboring words is constant
1349   }
1350 }
1351 @end lilypond"
1352   (justify-line-helper
1353     layout props args text-direction word-space line-width #t))
1354
1355 (define-markup-command (line layout props args)
1356   (markup-list?)
1357   #:category align
1358   #:properties ((word-space)
1359                 (text-direction RIGHT))
1360   "Put @var{args} in a horizontal line.  The property @code{word-space}
1361 determines the space between markups in @var{args}.
1362
1363 @lilypond[verbatim,quote]
1364 \\markup {
1365   \\line {
1366     one two three
1367   }
1368 }
1369 @end lilypond"
1370   (let ((stencils (interpret-markup-list layout props args)))
1371     (if (= text-direction LEFT)
1372         (set! stencils (reverse stencils)))
1373     (stack-stencil-line word-space stencils)))
1374
1375 (define-markup-command (concat layout props args)
1376   (markup-list?)
1377   #:category align
1378   "
1379 @cindex concatenating text
1380 @cindex ligatures in text
1381
1382 Concatenate @var{args} in a horizontal line, without spaces in between.
1383 Strings and simple markups are concatenated on the input level, allowing
1384 ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
1385 equivalent to @code{\"fi\"}.
1386
1387 @lilypond[verbatim,quote]
1388 \\markup {
1389   \\concat {
1390     one
1391     two
1392     three
1393   }
1394 }
1395 @end lilypond"
1396   (define (concat-string-args arg-list)
1397     (fold-right (lambda (arg result-list)
1398                   (let ((result (if (pair? result-list)
1399                                     (car result-list)
1400                                     '())))
1401                     (if (and (pair? arg) (eqv? (car arg) simple-markup))
1402                         (set! arg (cadr arg)))
1403                     (if (and (string? result) (string? arg))
1404                         (cons (string-append arg result) (cdr result-list))
1405                         (cons arg result-list))))
1406                 '()
1407                 arg-list))
1408
1409   (interpret-markup layout
1410                     (prepend-alist-chain 'word-space 0 props)
1411                     (make-line-markup
1412                      (make-override-lines-markup-list
1413                       (cons 'word-space
1414                             (chain-assoc-get 'word-space props))
1415                       (if (markup-command-list? args)
1416                           args
1417                           (concat-string-args args))))))
1418
1419 (define (wordwrap-stencils stencils
1420                            justify base-space line-width text-dir)
1421   "Perform simple wordwrap, return stencil of each line."
1422   (define space (if justify
1423                     ;; justify only stretches lines.
1424                     (* 0.7 base-space)
1425                     base-space))
1426   (define (stencil-len s)
1427     (interval-end (ly:stencil-extent s X)))
1428   (define (maybe-shift line)
1429     (if (= text-dir LEFT)
1430         (ly:stencil-translate-axis
1431          line
1432          (- line-width (stencil-len line))
1433          X)
1434         line))
1435   (if (null? stencils)
1436       '()
1437       (let loop ((lines '())
1438                  (todo stencils))
1439         (let word-loop
1440             ((line (first todo))
1441              (todo (cdr todo))
1442              (word-list (list (first todo))))
1443           (cond
1444            ((pair? todo)
1445             (let ((new (if (= text-dir LEFT)
1446                            (ly:stencil-stack (car todo) X RIGHT line space)
1447                            (ly:stencil-stack line X RIGHT (car todo) space))))
1448               (cond
1449                ((<= (stencil-len new) line-width)
1450                 (word-loop new (cdr todo)
1451                            (cons (car todo) word-list)))
1452                (justify
1453                 (let* ((word-list
1454                         ;; This depends on stencil stacking being
1455                         ;; associative so that stacking
1456                         ;; left-to-right and right-to-left leads to
1457                         ;; the same result
1458                         (if (= text-dir LEFT)
1459                             word-list
1460                             (reverse! word-list)))
1461                        (len (stencil-len line))
1462                        (stretch (- line-width len))
1463                        (spaces
1464                         (- (stencil-len
1465                             (stack-stencils X RIGHT (1+ space) word-list))
1466                            len)))
1467                   (if (zero? spaces)
1468                       ;; Uh oh, nothing to fill.
1469                       (loop (cons (maybe-shift line) lines) todo)
1470                       (loop (cons
1471                              (stack-stencils X RIGHT
1472                                              (+ space (/ stretch spaces))
1473                                              word-list)
1474                              lines)
1475                             todo))))
1476                (else ;; not justify
1477                 (loop (cons (maybe-shift line) lines) todo)))))
1478            ;; todo is null
1479            (justify
1480             ;; Now we have the last line assembled with space
1481             ;; which is compressed.  We want to use the
1482             ;; uncompressed version instead if it fits, and the
1483             ;; justified version if it doesn't.
1484             (let* ((word-list
1485                     ;; This depends on stencil stacking being
1486                     ;; associative so that stacking
1487                     ;; left-to-right and right-to-left leads to
1488                     ;; the same result
1489                     (if (= text-dir LEFT)
1490                         word-list
1491                         (reverse! word-list)))
1492                    (big-line (stack-stencils X RIGHT base-space word-list))
1493                    (big-len (stencil-len big-line))
1494                    (len (stencil-len line)))
1495               (reverse! lines
1496                         (list
1497                          (if (> big-len line-width)
1498                              (stack-stencils X RIGHT
1499                                              (/
1500                                               (+
1501                                                (* (- big-len line-width)
1502                                                   space)
1503                                                (* (- line-width len)
1504                                                   base-space))
1505                                               (- big-len len))
1506                                              word-list)
1507                              (maybe-shift big-line))))))
1508            (else ;; not justify
1509             (reverse! lines (list (maybe-shift line)))))))))
1510
1511
1512 (define-markup-list-command (wordwrap-internal layout props justify args)
1513   (boolean? markup-list?)
1514   #:properties ((line-width #f)
1515                 (word-space)
1516                 (text-direction RIGHT))
1517   "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}."
1518   (wordwrap-stencils (interpret-markup-list layout props args)
1519                      justify
1520                      word-space
1521                      (or line-width
1522                          (ly:output-def-lookup layout 'line-width))
1523                      text-direction))
1524
1525 (define-markup-command (justify layout props args)
1526   (markup-list?)
1527   #:category align
1528   #:properties ((baseline-skip)
1529                 wordwrap-internal-markup-list)
1530   "
1531 @cindex justifying text
1532
1533 Like @code{\\wordwrap}, but with lines stretched to justify the margins.
1534 Use @code{\\override #'(line-width . @var{X})} to set the line width;
1535 @var{X}@tie{}is the number of staff spaces.
1536
1537 @lilypond[verbatim,quote]
1538 \\markup {
1539   \\justify {
1540     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1541     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1542     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1543     laboris nisi ut aliquip ex ea commodo consequat.
1544   }
1545 }
1546 @end lilypond"
1547   (stack-lines DOWN 0.0 baseline-skip
1548                (wordwrap-internal-markup-list layout props #t args)))
1549
1550 (define-markup-command (wordwrap layout props args)
1551   (markup-list?)
1552   #:category align
1553   #:properties ((baseline-skip)
1554                 wordwrap-internal-markup-list)
1555   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
1556 the line width, where @var{X} is the number of staff spaces.
1557
1558 @lilypond[verbatim,quote]
1559 \\markup {
1560   \\wordwrap {
1561     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1562     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1563     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1564     laboris nisi ut aliquip ex ea commodo consequat.
1565   }
1566 }
1567 @end lilypond"
1568   (stack-lines DOWN 0.0 baseline-skip
1569                (wordwrap-internal-markup-list layout props #f args)))
1570
1571 (define-markup-list-command (wordwrap-string-internal layout props justify arg)
1572   (boolean? string?)
1573   #:properties ((line-width)
1574                 (word-space)
1575                 (text-direction RIGHT))
1576   "Internal markup list command used to define @code{\\justify-string} and
1577 @code{\\wordwrap-string}."
1578   (let* ((para-strings (regexp-split
1579                         (string-regexp-substitute
1580                          "\r" "\n"
1581                          (string-regexp-substitute "\r\n" "\n" arg))
1582                         "\n[ \t\n]*\n[ \t\n]*"))
1583          (list-para-words (map (lambda (str)
1584                                  (regexp-split str "[ \t\n]+"))
1585                                para-strings))
1586          (para-lines (map (lambda (words)
1587                             (let* ((stencils
1588                                     (map (lambda (x)
1589                                            (interpret-markup layout props x))
1590                                          words)))
1591                               (wordwrap-stencils stencils
1592                                                  justify word-space
1593                                                  line-width text-direction)))
1594                           list-para-words)))
1595     (concatenate para-lines)))
1596
1597 (define-markup-command (wordwrap-string layout props arg)
1598   (string?)
1599   #:category align
1600   #:properties ((baseline-skip)
1601                 wordwrap-string-internal-markup-list)
1602   "Wordwrap a string.  Paragraphs may be separated with double newlines.
1603
1604 @lilypond[verbatim,quote]
1605 \\markup {
1606   \\override #'(line-width . 40)
1607   \\wordwrap-string #\"Lorem ipsum dolor sit amet, consectetur
1608       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1609       et dolore magna aliqua.
1610
1611
1612       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1613       laboris nisi ut aliquip ex ea commodo consequat.
1614
1615
1616       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1617       qui officia deserunt mollit anim id est laborum\"
1618 }
1619 @end lilypond"
1620   (stack-lines DOWN 0.0 baseline-skip
1621                (wordwrap-string-internal-markup-list layout props #f arg)))
1622
1623 (define-markup-command (justify-string layout props arg)
1624   (string?)
1625   #:category align
1626   #:properties ((baseline-skip)
1627                 wordwrap-string-internal-markup-list)
1628   "Justify a string.  Paragraphs may be separated with double newlines
1629
1630 @lilypond[verbatim,quote]
1631 \\markup {
1632   \\override #'(line-width . 40)
1633   \\justify-string #\"Lorem ipsum dolor sit amet, consectetur
1634       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1635       et dolore magna aliqua.
1636
1637
1638       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1639       laboris nisi ut aliquip ex ea commodo consequat.
1640
1641
1642       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1643       qui officia deserunt mollit anim id est laborum\"
1644 }
1645 @end lilypond"
1646   (stack-lines DOWN 0.0 baseline-skip
1647                (wordwrap-string-internal-markup-list layout props #t arg)))
1648
1649 (define-markup-command (wordwrap-field layout props symbol)
1650   (symbol?)
1651   #:category align
1652   "Wordwrap the data which has been assigned to @var{symbol}.
1653
1654 @lilypond[verbatim,quote]
1655 \\header {
1656   title = \"My title\"
1657   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1658     elit, sed do eiusmod tempor incididunt ut labore et dolore
1659     magna aliqua.  Ut enim ad minim veniam, quis nostrud
1660     exercitation ullamco laboris nisi ut aliquip ex ea commodo
1661     consequat.\"
1662 }
1663
1664 \\paper {
1665   bookTitleMarkup = \\markup {
1666     \\column {
1667       \\fill-line { \\fromproperty #'header:title }
1668       \\null
1669       \\wordwrap-field #'header:myText
1670     }
1671   }
1672 }
1673
1674 \\markup {
1675   \\null
1676 }
1677 @end lilypond"
1678   (let* ((m (chain-assoc-get symbol props)))
1679     (if (string? m)
1680         (wordwrap-string-markup layout props m)
1681         empty-stencil)))
1682
1683 (define-markup-command (justify-field layout props symbol)
1684   (symbol?)
1685   #:category align
1686   "Justify the data which has been assigned to @var{symbol}.
1687
1688 @lilypond[verbatim,quote]
1689 \\header {
1690   title = \"My title\"
1691   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1692     elit, sed do eiusmod tempor incididunt ut labore et dolore magna
1693     aliqua.  Ut enim ad minim veniam, quis nostrud exercitation ullamco
1694     laboris nisi ut aliquip ex ea commodo consequat.\"
1695 }
1696
1697 \\paper {
1698   bookTitleMarkup = \\markup {
1699     \\column {
1700       \\fill-line { \\fromproperty #'header:title }
1701       \\null
1702       \\justify-field #'header:myText
1703     }
1704   }
1705 }
1706
1707 \\markup {
1708   \\null
1709 }
1710 @end lilypond"
1711   (let* ((m (chain-assoc-get symbol props)))
1712     (if (string? m)
1713         (justify-string-markup layout props m)
1714         empty-stencil)))
1715
1716 (define-markup-command (combine layout props arg1 arg2)
1717   (markup? markup?)
1718   #:category align
1719   "
1720 @cindex merging text
1721
1722 Print two markups on top of each other.
1723
1724 Note: @code{\\combine} cannot take a list of markups enclosed in
1725 curly braces as an argument; the follow example will not compile:
1726
1727 @example
1728 \\combine @{ a list @}
1729 @end example
1730
1731 @lilypond[verbatim,quote]
1732 \\markup {
1733   \\fontsize #5
1734   \\override #'(thickness . 2)
1735   \\combine
1736     \\draw-line #'(0 . 4)
1737     \\arrow-head #Y #DOWN ##f
1738 }
1739 @end lilypond"
1740   (let* ((s1 (interpret-markup layout props arg1))
1741          (s2 (interpret-markup layout props arg2)))
1742     (ly:stencil-add s1 s2)))
1743
1744 ;;
1745 ;; TODO: should extract baseline-skip from each argument somehow..
1746 ;;
1747 (define-markup-command (column layout props args)
1748   (markup-list?)
1749   #:category align
1750   #:properties ((baseline-skip))
1751   "
1752 @cindex stacking text in a column
1753
1754 Stack the markups in @var{args} vertically.  The property
1755 @code{baseline-skip} determines the space between markups
1756 in @var{args}.
1757
1758 @lilypond[verbatim,quote]
1759 \\markup {
1760   \\column {
1761     one
1762     two
1763     three
1764   }
1765 }
1766 @end lilypond"
1767   (let ((arg-stencils (interpret-markup-list layout props args)))
1768     (stack-lines -1 0.0 baseline-skip arg-stencils)))
1769
1770 (define-markup-command (dir-column layout props args)
1771   (markup-list?)
1772   #:category align
1773   #:properties ((direction)
1774                 (baseline-skip))
1775   "
1776 @cindex changing direction of text columns
1777
1778 Make a column of @var{args}, going up or down, depending on the
1779 setting of the @code{direction} layout property.
1780
1781 @lilypond[verbatim,quote]
1782 \\markup {
1783   \\override #`(direction . ,UP) {
1784     \\dir-column {
1785       going up
1786     }
1787   }
1788   \\hspace #1
1789   \\dir-column {
1790     going down
1791   }
1792   \\hspace #1
1793   \\override #'(direction . 1) {
1794     \\dir-column {
1795       going up
1796     }
1797   }
1798 }
1799 @end lilypond"
1800   (stack-lines (if (number? direction) direction -1)
1801                0.0
1802                baseline-skip
1803                (interpret-markup-list layout props args)))
1804
1805 (define (general-column align-dir baseline mols)
1806   "Stack @var{mols} vertically, aligned to  @var{align-dir} horizontally."
1807
1808   (let* ((aligned-mols (map (lambda (x) (ly:stencil-aligned-to x X align-dir)) mols))
1809          (stacked-stencil (stack-lines -1 0.0 baseline aligned-mols))
1810          (stacked-extent (ly:stencil-extent stacked-stencil X)))
1811     (ly:stencil-translate-axis stacked-stencil (- (car stacked-extent)) X )))
1812
1813 (define-markup-command (center-column layout props args)
1814   (markup-list?)
1815   #:category align
1816   #:properties ((baseline-skip))
1817   "
1818 @cindex centering a column of text
1819
1820 Put @code{args} in a centered column.
1821
1822 @lilypond[verbatim,quote]
1823 \\markup {
1824   \\center-column {
1825     one
1826     two
1827     three
1828   }
1829 }
1830 @end lilypond"
1831   (general-column CENTER baseline-skip (interpret-markup-list layout props args)))
1832
1833 (define-markup-command (left-column layout props args)
1834   (markup-list?)
1835   #:category align
1836   #:properties ((baseline-skip))
1837   "
1838 @cindex text columns, left-aligned
1839
1840 Put @code{args} in a left-aligned column.
1841
1842 @lilypond[verbatim,quote]
1843 \\markup {
1844   \\left-column {
1845     one
1846     two
1847     three
1848   }
1849 }
1850 @end lilypond"
1851   (general-column LEFT baseline-skip (interpret-markup-list layout props args)))
1852
1853 (define-markup-command (right-column layout props args)
1854   (markup-list?)
1855   #:category align
1856   #:properties ((baseline-skip))
1857   "
1858 @cindex text columns, right-aligned
1859
1860 Put @code{args} in a right-aligned column.
1861
1862 @lilypond[verbatim,quote]
1863 \\markup {
1864   \\right-column {
1865     one
1866     two
1867     three
1868   }
1869 }
1870 @end lilypond"
1871   (general-column RIGHT baseline-skip (interpret-markup-list layout props args)))
1872
1873 (define-markup-command (vcenter layout props arg)
1874   (markup?)
1875   #:category align
1876   "
1877 @cindex vertically centering text
1878
1879 Align @code{arg} to its Y@tie{}center.
1880
1881 @lilypond[verbatim,quote]
1882 \\markup {
1883   one
1884   \\vcenter
1885   two
1886   three
1887 }
1888 @end lilypond"
1889   (let* ((mol (interpret-markup layout props arg)))
1890     (ly:stencil-aligned-to mol Y CENTER)))
1891
1892 (define-markup-command (center-align layout props arg)
1893   (markup?)
1894   #:category align
1895   "
1896 @cindex horizontally centering text
1897
1898 Align @code{arg} to its X@tie{}center.
1899
1900 @lilypond[verbatim,quote]
1901 \\markup {
1902   \\column {
1903     one
1904     \\center-align
1905     two
1906     three
1907   }
1908 }
1909 @end lilypond"
1910   (let* ((mol (interpret-markup layout props arg)))
1911     (ly:stencil-aligned-to mol X CENTER)))
1912
1913 (define-markup-command (right-align layout props arg)
1914   (markup?)
1915   #:category align
1916   "
1917 @cindex right aligning text
1918
1919 Align @var{arg} on its right edge.
1920
1921 @lilypond[verbatim,quote]
1922 \\markup {
1923   \\column {
1924     one
1925     \\right-align
1926     two
1927     three
1928   }
1929 }
1930 @end lilypond"
1931   (let* ((m (interpret-markup layout props arg)))
1932     (ly:stencil-aligned-to m X RIGHT)))
1933
1934 (define-markup-command (left-align layout props arg)
1935   (markup?)
1936   #:category align
1937   "
1938 @cindex left aligning text
1939
1940 Align @var{arg} on its left edge.
1941
1942 @lilypond[verbatim,quote]
1943 \\markup {
1944   \\column {
1945     one
1946     \\left-align
1947     two
1948     three
1949   }
1950 }
1951 @end lilypond"
1952   (let* ((m (interpret-markup layout props arg)))
1953     (ly:stencil-aligned-to m X LEFT)))
1954
1955 (define-markup-command (general-align layout props axis dir arg)
1956   (integer? number? markup?)
1957   #:category align
1958   "
1959 @cindex controlling general text alignment
1960
1961 Align @var{arg} in @var{axis} direction to the @var{dir} side.
1962
1963 @lilypond[verbatim,quote]
1964 \\markup {
1965   \\column {
1966     one
1967     \\general-align #X #LEFT
1968     two
1969     three
1970     \\null
1971     one
1972     \\general-align #X #CENTER
1973     two
1974     three
1975     \\null
1976     \\line {
1977       one
1978       \\general-align #Y #UP
1979       two
1980       three
1981     }
1982     \\null
1983     \\line {
1984       one
1985       \\general-align #Y #3.2
1986       two
1987       three
1988     }
1989   }
1990 }
1991 @end lilypond"
1992   (let* ((m (interpret-markup layout props arg)))
1993     (ly:stencil-aligned-to m axis dir)))
1994
1995 (define-markup-command (halign layout props dir arg)
1996   (number? markup?)
1997   #:category align
1998   "
1999 @cindex setting horizontal text alignment
2000
2001 Set horizontal alignment.  If @var{dir} is @w{@code{-1}}, then it is
2002 left-aligned, while @code{+1} is right.  Values in between interpolate
2003 alignment accordingly.
2004
2005 @lilypond[verbatim,quote]
2006 \\markup {
2007   \\column {
2008     one
2009     \\halign #LEFT
2010     two
2011     three
2012     \\null
2013     one
2014     \\halign #CENTER
2015     two
2016     three
2017     \\null
2018     one
2019     \\halign #RIGHT
2020     two
2021     three
2022     \\null
2023     one
2024     \\halign #-5
2025     two
2026     three
2027   }
2028 }
2029 @end lilypond"
2030   (let* ((m (interpret-markup layout props arg)))
2031     (ly:stencil-aligned-to m X dir)))
2032
2033 (define-markup-command (with-dimensions layout props x y arg)
2034   (number-pair? number-pair? markup?)
2035   #:category other
2036   "
2037 @cindex setting extent of text objects
2038
2039 Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}."
2040   (let* ((expr (ly:stencil-expr (interpret-markup layout props arg))))
2041     (ly:stencil-add
2042      (make-transparent-box-stencil x y)
2043      (ly:make-stencil
2044       `(delay-stencil-evaluation ,(delay expr))
2045       x y))))
2046
2047 (define-markup-command (pad-around layout props amount arg)
2048   (number? markup?)
2049   #:category align
2050   "Add padding @var{amount} all around @var{arg}.
2051
2052 @lilypond[verbatim,quote]
2053 \\markup {
2054   \\box {
2055     default
2056   }
2057   \\hspace #2
2058   \\box {
2059     \\pad-around #0.5 {
2060       padded
2061     }
2062   }
2063 }
2064 @end lilypond"
2065   (let* ((m (interpret-markup layout props arg))
2066          (x (interval-widen (ly:stencil-extent m X) amount))
2067          (y (interval-widen (ly:stencil-extent m Y) amount)))
2068     (ly:stencil-add (make-transparent-box-stencil x y)
2069                     m)))
2070
2071 (define-markup-command (pad-x layout props amount arg)
2072   (number? markup?)
2073   #:category align
2074   "
2075 @cindex padding text horizontally
2076
2077 Add padding @var{amount} around @var{arg} in the X@tie{}direction.
2078
2079 @lilypond[verbatim,quote]
2080 \\markup {
2081   \\box {
2082     default
2083   }
2084   \\hspace #4
2085   \\box {
2086     \\pad-x #2 {
2087       padded
2088     }
2089   }
2090 }
2091 @end lilypond"
2092   (let* ((m (interpret-markup layout props arg))
2093          (x (ly:stencil-extent m X))
2094          (y (ly:stencil-extent m Y)))
2095     (ly:make-stencil (ly:stencil-expr m)
2096                      (interval-widen x amount)
2097                      y)))
2098
2099 (define-markup-command (put-adjacent layout props axis dir arg1 arg2)
2100   (integer? ly:dir? markup? markup?)
2101   #:category align
2102   "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}."
2103   (let ((m1 (interpret-markup layout props arg1))
2104         (m2 (interpret-markup layout props arg2)))
2105     (ly:stencil-combine-at-edge m1 axis dir m2 0.0)))
2106
2107 (define-markup-command (transparent layout props arg)
2108   (markup?)
2109   #:category other
2110   "Make @var{arg} transparent.
2111
2112 @lilypond[verbatim,quote]
2113 \\markup {
2114   \\transparent {
2115     invisible text
2116   }
2117 }
2118 @end lilypond"
2119   (let* ((m (interpret-markup layout props arg))
2120          (x (ly:stencil-extent m X))
2121          (y (ly:stencil-extent m Y)))
2122     (ly:make-stencil (list 'transparent-stencil (ly:stencil-expr m)) x y)))
2123
2124 (define-markup-command (pad-to-box layout props x-ext y-ext arg)
2125   (number-pair? number-pair? markup?)
2126   #:category align
2127   "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space.
2128
2129 @lilypond[verbatim,quote]
2130 \\markup {
2131   \\box {
2132     default
2133   }
2134   \\hspace #4
2135   \\box {
2136     \\pad-to-box #'(0 . 10) #'(0 . 3) {
2137       padded
2138     }
2139   }
2140 }
2141 @end lilypond"
2142   (ly:stencil-add (make-transparent-box-stencil x-ext y-ext)
2143                   (interpret-markup layout props arg)))
2144
2145 (define-markup-command (hcenter-in layout props length arg)
2146   (number? markup?)
2147   #:category align
2148   "Center @var{arg} horizontally within a box of extending
2149 @var{length}/2 to the left and right.
2150
2151 @lilypond[quote,verbatim]
2152 \\new StaffGroup <<
2153   \\new Staff {
2154     \\set Staff.instrumentName = \\markup {
2155       \\hcenter-in #12
2156       Oboe
2157     }
2158     c''1
2159   }
2160   \\new Staff {
2161     \\set Staff.instrumentName = \\markup {
2162       \\hcenter-in #12
2163       Bassoon
2164     }
2165     \\clef tenor
2166     c'1
2167   }
2168 >>
2169 @end lilypond"
2170   (interpret-markup layout props
2171                     (make-pad-to-box-markup
2172                      (cons (/ length -2) (/ length 2))
2173                      '(0 . 0)
2174                      (make-center-align-markup arg))))
2175
2176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2177 ;; property
2178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2179
2180 (define-markup-command (property-recursive layout props symbol)
2181   (symbol?)
2182   #:category other
2183   "Print out a warning when a header field markup contains some recursive
2184 markup definition."
2185   (ly:warning "Recursive definition of property ~a detected!" symbol)
2186   empty-stencil)
2187
2188 (define-markup-command (fromproperty layout props symbol)
2189   (symbol?)
2190   #:category other
2191   "Read the @var{symbol} from property settings, and produce a stencil
2192 from the markup contained within.  If @var{symbol} is not defined, it
2193 returns an empty markup.
2194
2195 @lilypond[verbatim,quote]
2196 \\header {
2197   myTitle = \"myTitle\"
2198   title = \\markup {
2199     from
2200     \\italic
2201     \\fromproperty #'header:myTitle
2202   }
2203 }
2204 \\markup {
2205   \\null
2206 }
2207 @end lilypond"
2208   (let ((m (chain-assoc-get symbol props)))
2209     (if (markup? m)
2210         ;; prevent infinite loops by clearing the interpreted property:
2211         (interpret-markup layout (cons (list (cons symbol `(,property-recursive-markup ,symbol))) props) m)
2212         empty-stencil)))
2213
2214 (define-markup-command (on-the-fly layout props procedure arg)
2215   (procedure? markup?)
2216   #:category other
2217   "Apply the @var{procedure} markup command to @var{arg}.
2218 @var{procedure} should take a single argument."
2219   (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
2220     (set-object-property! anonymous-with-signature
2221                           'markup-signature
2222                           (list markup?))
2223     (interpret-markup layout props (list anonymous-with-signature arg))))
2224
2225 (define-markup-command (footnote layout props mkup note)
2226   (markup? markup?)
2227   #:category other
2228   "Have footnote @var{note} act as an annotation to the markup @var{mkup}.
2229
2230 @lilypond[verbatim,quote]
2231 \\markup {
2232   \\auto-footnote a b
2233   \\override #'(padding . 0.2)
2234   \\auto-footnote c d
2235 }
2236 @end lilypond
2237 The footnote will not be annotated automatically."
2238   (ly:stencil-combine-at-edge
2239    (interpret-markup layout props mkup)
2240    X
2241    RIGHT
2242    (ly:make-stencil
2243     `(footnote (gensym "footnote") #f ,(interpret-markup layout props note))
2244     '(0 . 0)
2245     '(0 . 0))
2246    0.0))
2247
2248 (define-markup-command (auto-footnote layout props mkup note)
2249   (markup? markup?)
2250   #:category other
2251   #:properties ((raise 0.5)
2252                 (padding 0.0))
2253   "Have footnote @var{note} act as an annotation to the markup @var{mkup}.
2254
2255 @lilypond[verbatim,quote]
2256 \\markup {
2257   \\auto-footnote a b
2258   \\override #'(padding . 0.2)
2259   \\auto-footnote c d
2260 }
2261 @end lilypond
2262 The footnote will be annotated automatically."
2263   (let* ((markup-stencil (interpret-markup layout props mkup))
2264          (footnote-hash (gensym "footnote"))
2265          (stencil-seed 0)
2266          (gauge-stencil (interpret-markup
2267                          layout
2268                          props
2269                          ((ly:output-def-lookup
2270                            layout
2271                            'footnote-numbering-function)
2272                           stencil-seed)))
2273          (x-ext (ly:stencil-extent gauge-stencil X))
2274          (y-ext (ly:stencil-extent gauge-stencil Y))
2275          (footnote-number
2276           `(delay-stencil-evaluation
2277             ,(delay
2278                (ly:stencil-expr
2279                 (let* ((table
2280                         (ly:output-def-lookup layout
2281                                               'number-footnote-table))
2282                        (footnote-stencil (if (list? table)
2283                                              (assoc-get footnote-hash
2284                                                         table)
2285                                              empty-stencil))
2286                        (footnote-stencil (if (ly:stencil? footnote-stencil)
2287                                              footnote-stencil
2288                                              (begin
2289                                                (ly:programming-error
2290                                                 "Cannot find correct footnote for a markup object.")
2291                                                empty-stencil)))
2292                        (gap (- (interval-length x-ext)
2293                                (interval-length
2294                                 (ly:stencil-extent footnote-stencil X))))
2295                        (y-trans (- (+ (cdr y-ext)
2296                                       raise)
2297                                    (cdr (ly:stencil-extent footnote-stencil
2298                                                            Y)))))
2299                   (ly:stencil-translate footnote-stencil
2300                                         (cons gap y-trans)))))))
2301          (main-stencil (ly:stencil-combine-at-edge
2302                         markup-stencil
2303                         X
2304                         RIGHT
2305                         (ly:make-stencil footnote-number x-ext y-ext)
2306                         padding)))
2307     (ly:stencil-add
2308      main-stencil
2309      (ly:make-stencil
2310       `(footnote ,footnote-hash #t ,(interpret-markup layout props note))
2311       '(0 . 0)
2312       '(0 . 0)))))
2313
2314 (define-markup-command (override layout props new-prop arg)
2315   (pair? markup?)
2316   #:category other
2317   "
2318 @cindex overriding properties within text markup
2319
2320 Add the argument @var{new-prop} to the property list.  Properties
2321 may be any property supported by @rinternals{font-interface},
2322 @rinternals{text-interface} and
2323 @rinternals{instrument-specific-markup-interface}.
2324
2325 @lilypond[verbatim,quote]
2326 \\markup {
2327   \\line {
2328     \\column {
2329       default
2330       baseline-skip
2331     }
2332     \\hspace #2
2333     \\override #'(baseline-skip . 4) {
2334       \\column {
2335         increased
2336         baseline-skip
2337       }
2338     }
2339   }
2340 }
2341 @end lilypond"
2342   (interpret-markup layout (cons (list new-prop) props) arg))
2343
2344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2345 ;; files
2346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2347
2348 (define-markup-command (verbatim-file layout props name)
2349   (string?)
2350   #:category other
2351   "Read the contents of file @var{name}, and include it verbatim.
2352
2353 @lilypond[verbatim,quote]
2354 \\markup {
2355   \\verbatim-file #\"simple.ly\"
2356 }
2357 @end lilypond"
2358   (interpret-markup layout props
2359                     (if  (ly:get-option 'safe)
2360                          "verbatim-file disabled in safe mode"
2361                          (let* ((str (ly:gulp-file name))
2362                                 (lines (string-split str #\nl)))
2363                            (make-typewriter-markup
2364                             (make-column-markup lines))))))
2365
2366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2367 ;; fonts.
2368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2369
2370
2371 (define-markup-command (smaller layout props arg)
2372   (markup?)
2373   #:category font
2374   "Decrease the font size relative to the current setting.
2375
2376 @lilypond[verbatim,quote]
2377 \\markup {
2378   \\fontsize #3.5 {
2379     some large text
2380     \\hspace #2
2381     \\smaller {
2382       a bit smaller
2383     }
2384     \\hspace #2
2385     more large text
2386   }
2387 }
2388 @end lilypond"
2389   (interpret-markup layout props
2390                     `(,fontsize-markup -1 ,arg)))
2391
2392 (define-markup-command (larger layout props arg)
2393   (markup?)
2394   #:category font
2395   "Increase the font size relative to the current setting.
2396
2397 @lilypond[verbatim,quote]
2398 \\markup {
2399   default
2400   \\hspace #2
2401   \\larger
2402   larger
2403 }
2404 @end lilypond"
2405   (interpret-markup layout props
2406                     `(,fontsize-markup 1 ,arg)))
2407
2408 (define-markup-command (finger layout props arg)
2409   (markup?)
2410   #:category font
2411   "Set @var{arg} as small numbers.
2412
2413 @lilypond[verbatim,quote]
2414 \\markup {
2415   \\finger {
2416     1 2 3 4 5
2417   }
2418 }
2419 @end lilypond"
2420   (interpret-markup layout
2421                     (cons '((font-size . -5) (font-encoding . fetaText)) props)
2422                     arg))
2423
2424 (define-markup-command (abs-fontsize layout props size arg)
2425   (number? markup?)
2426   #:category font
2427   "Use @var{size} as the absolute font size to display @var{arg}.
2428 Adjusts @code{baseline-skip} and @code{word-space} accordingly.
2429
2430 @lilypond[verbatim,quote]
2431 \\markup {
2432   default text font size
2433   \\hspace #2
2434   \\abs-fontsize #16 { text font size 16 }
2435   \\hspace #2
2436   \\abs-fontsize #12 { text font size 12 }
2437 }
2438 @end lilypond"
2439   (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12))
2440          (text-props (list (ly:output-def-lookup layout 'text-font-defaults)))
2441          (ref-word-space (chain-assoc-get 'word-space text-props 0.6))
2442          (ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
2443          (magnification (/ size ref-size)))
2444     (interpret-markup
2445      layout
2446      (cons
2447       `((baseline-skip . ,(* magnification ref-baseline))
2448         (word-space . ,(* magnification ref-word-space))
2449         (font-size . ,(magnification->font-size magnification)))
2450       props)
2451      arg)))
2452
2453 (define-markup-command (fontsize layout props increment arg)
2454   (number? markup?)
2455   #:category font
2456   #:properties ((font-size 0)
2457                 (word-space 1)
2458                 (baseline-skip 2))
2459   "Add @var{increment} to the font-size.  Adjusts @code{baseline-skip}
2460 accordingly.
2461
2462 @lilypond[verbatim,quote]
2463 \\markup {
2464   default
2465   \\hspace #2
2466   \\fontsize #-1.5
2467   smaller
2468 }
2469 @end lilypond"
2470   (interpret-markup
2471    layout
2472    (cons
2473     `((baseline-skip . ,(* baseline-skip (magstep increment)))
2474       (word-space . ,(* word-space (magstep increment)))
2475       (font-size . ,(+ font-size increment)))
2476     props)
2477    arg))
2478
2479 (define-markup-command (magnify layout props sz arg)
2480   (number? markup?)
2481   #:category font
2482   "
2483 @cindex magnifying text
2484
2485 Set the font magnification for its argument.  In the following
2486 example, the middle@tie{}A is 10% larger:
2487
2488 @example
2489 A \\magnify #1.1 @{ A @} A
2490 @end example
2491
2492 Note: Magnification only works if a font name is explicitly selected.
2493 Use @code{\\fontsize} otherwise.
2494
2495 @lilypond[verbatim,quote]
2496 \\markup {
2497   default
2498   \\hspace #2
2499   \\magnify #1.5 {
2500     50% larger
2501   }
2502 }
2503 @end lilypond"
2504   (interpret-markup
2505    layout
2506    (prepend-alist-chain 'font-size (magnification->font-size sz) props)
2507    arg))
2508
2509 (define-markup-command (bold layout props arg)
2510   (markup?)
2511   #:category font
2512   "Switch to bold font-series.
2513
2514 @lilypond[verbatim,quote]
2515 \\markup {
2516   default
2517   \\hspace #2
2518   \\bold
2519   bold
2520 }
2521 @end lilypond"
2522   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
2523
2524 (define-markup-command (sans layout props arg)
2525   (markup?)
2526   #:category font
2527   "Switch to the sans serif font family.
2528
2529 @lilypond[verbatim,quote]
2530 \\markup {
2531   default
2532   \\hspace #2
2533   \\sans {
2534     sans serif
2535   }
2536 }
2537 @end lilypond"
2538   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
2539
2540 (define-markup-command (number layout props arg)
2541   (markup?)
2542   #:category font
2543   "Set font family to @code{number}, which yields the font used for
2544 time signatures and fingerings.  This font contains numbers and
2545 some punctuation; it has no letters.
2546
2547 @lilypond[verbatim,quote]
2548 \\markup {
2549   \\number {
2550     0 1 2 3 4 5 6 7 8 9 . ,
2551   }
2552 }
2553 @end lilypond"
2554   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2555
2556 (define-markup-command (roman layout props arg)
2557   (markup?)
2558   #:category font
2559   "Set font family to @code{roman}.
2560
2561 @lilypond[verbatim,quote]
2562 \\markup {
2563   \\sans \\bold {
2564     sans serif, bold
2565     \\hspace #2
2566     \\roman {
2567       text in roman font family
2568     }
2569     \\hspace #2
2570     return to sans
2571   }
2572 }
2573 @end lilypond"
2574   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
2575
2576 (define-markup-command (huge layout props arg)
2577   (markup?)
2578   #:category font
2579   "Set font size to +2.
2580
2581 @lilypond[verbatim,quote]
2582 \\markup {
2583   default
2584   \\hspace #2
2585   \\huge
2586   huge
2587 }
2588 @end lilypond"
2589   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
2590
2591 (define-markup-command (large layout props arg)
2592   (markup?)
2593   #:category font
2594   "Set font size to +1.
2595
2596 @lilypond[verbatim,quote]
2597 \\markup {
2598   default
2599   \\hspace #2
2600   \\large
2601   large
2602 }
2603 @end lilypond"
2604   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
2605
2606 (define-markup-command (normalsize layout props arg)
2607   (markup?)
2608   #:category font
2609   "Set font size to default.
2610
2611 @lilypond[verbatim,quote]
2612 \\markup {
2613   \\teeny {
2614     this is very small
2615     \\hspace #2
2616     \\normalsize {
2617       normal size
2618     }
2619     \\hspace #2
2620     teeny again
2621   }
2622 }
2623 @end lilypond"
2624   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
2625
2626 (define-markup-command (small layout props arg)
2627   (markup?)
2628   #:category font
2629   "Set font size to -1.
2630
2631 @lilypond[verbatim,quote]
2632 \\markup {
2633   default
2634   \\hspace #2
2635   \\small
2636   small
2637 }
2638 @end lilypond"
2639   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
2640
2641 (define-markup-command (tiny layout props arg)
2642   (markup?)
2643   #:category font
2644   "Set font size to -2.
2645
2646 @lilypond[verbatim,quote]
2647 \\markup {
2648   default
2649   \\hspace #2
2650   \\tiny
2651   tiny
2652 }
2653 @end lilypond"
2654   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
2655
2656 (define-markup-command (teeny layout props arg)
2657   (markup?)
2658   #:category font
2659   "Set font size to -3.
2660
2661 @lilypond[verbatim,quote]
2662 \\markup {
2663   default
2664   \\hspace #2
2665   \\teeny
2666   teeny
2667 }
2668 @end lilypond"
2669   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
2670
2671 (define-markup-command (fontCaps layout props arg)
2672   (markup?)
2673   #:category font
2674   "Set @code{font-shape} to @code{caps}
2675
2676 Note: @code{\\fontCaps} requires the installation and selection of
2677 fonts which support the @code{caps} font shape."
2678   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
2679
2680 ;; Poor man's caps
2681 (define-markup-command (smallCaps layout props arg)
2682   (markup?)
2683   #:category font
2684   "Emit @var{arg} as small caps.
2685
2686 Note: @code{\\smallCaps} does not support accented characters.
2687
2688 @lilypond[verbatim,quote]
2689 \\markup {
2690   default
2691   \\hspace #2
2692   \\smallCaps {
2693     Text in small caps
2694   }
2695 }
2696 @end lilypond"
2697   (define (char-list->markup chars lower)
2698     (let ((final-string (string-upcase (reverse-list->string chars))))
2699       (if lower
2700           (markup #:fontsize -2 final-string)
2701           final-string)))
2702   (define (make-small-caps rest-chars currents current-is-lower prev-result)
2703     (if (null? rest-chars)
2704         (make-concat-markup
2705          (reverse! (cons (char-list->markup currents current-is-lower)
2706                          prev-result)))
2707         (let* ((ch (car rest-chars))
2708                (is-lower (char-lower-case? ch)))
2709           (if (or (and current-is-lower is-lower)
2710                   (and (not current-is-lower) (not is-lower)))
2711               (make-small-caps (cdr rest-chars)
2712                                (cons ch currents)
2713                                is-lower
2714                                prev-result)
2715               (make-small-caps (cdr rest-chars)
2716                                (list ch)
2717                                is-lower
2718                                (if (null? currents)
2719                                    prev-result
2720                                    (cons (char-list->markup
2721                                           currents current-is-lower)
2722                                          prev-result)))))))
2723   (interpret-markup layout props
2724                     (if (string? arg)
2725                         (make-small-caps (string->list arg) (list) #f (list))
2726                         arg)))
2727
2728 (define-markup-command (caps layout props arg)
2729   (markup?)
2730   #:category font
2731   "Copy of the @code{\\smallCaps} command.
2732
2733 @lilypond[verbatim,quote]
2734 \\markup {
2735   default
2736   \\hspace #2
2737   \\caps {
2738     Text in small caps
2739   }
2740 }
2741 @end lilypond"
2742   (interpret-markup layout props (make-smallCaps-markup arg)))
2743
2744 (define-markup-command (dynamic layout props arg)
2745   (markup?)
2746   #:category font
2747   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
2748 @b{z}, @b{p}, and @b{r}.  When producing phrases, like
2749 @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be
2750 done in a different font.  The recommended font for this is bold and italic.
2751 @lilypond[verbatim,quote]
2752 \\markup {
2753   \\dynamic {
2754     sfzp
2755   }
2756 }
2757 @end lilypond"
2758   (interpret-markup
2759    layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2760
2761 (define-markup-command (text layout props arg)
2762   (markup?)
2763   #:category font
2764   "Use a text font instead of music symbol or music alphabet font.
2765
2766 @lilypond[verbatim,quote]
2767 \\markup {
2768   \\number {
2769     1, 2,
2770     \\text {
2771       three, four,
2772     }
2773     5
2774   }
2775 }
2776 @end lilypond"
2777
2778   ;; ugh - latin1
2779   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
2780                     arg))
2781
2782 (define-markup-command (italic layout props arg)
2783   (markup?)
2784   #:category font
2785   "Use italic @code{font-shape} for @var{arg}.
2786
2787 @lilypond[verbatim,quote]
2788 \\markup {
2789   default
2790   \\hspace #2
2791   \\italic
2792   italic
2793 }
2794 @end lilypond"
2795   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
2796
2797 (define-markup-command (typewriter layout props arg)
2798   (markup?)
2799   #:category font
2800   "Use @code{font-family} typewriter for @var{arg}.
2801
2802 @lilypond[verbatim,quote]
2803 \\markup {
2804   default
2805   \\hspace #2
2806   \\typewriter
2807   typewriter
2808 }
2809 @end lilypond"
2810   (interpret-markup
2811    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
2812
2813 (define-markup-command (upright layout props arg)
2814   (markup?)
2815   #:category font
2816   "Set @code{font-shape} to @code{upright}.  This is the opposite
2817 of @code{italic}.
2818
2819 @lilypond[verbatim,quote]
2820 \\markup {
2821   \\italic {
2822     italic text
2823     \\hspace #2
2824     \\upright {
2825       upright text
2826     }
2827     \\hspace #2
2828     italic again
2829   }
2830 }
2831 @end lilypond"
2832   (interpret-markup
2833    layout (prepend-alist-chain 'font-shape 'upright props) arg))
2834
2835 (define-markup-command (medium layout props arg)
2836   (markup?)
2837   #:category font
2838   "Switch to medium font-series (in contrast to bold).
2839
2840 @lilypond[verbatim,quote]
2841 \\markup {
2842   \\bold {
2843     some bold text
2844     \\hspace #2
2845     \\medium {
2846       medium font series
2847     }
2848     \\hspace #2
2849     bold again
2850   }
2851 }
2852 @end lilypond"
2853   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
2854                     arg))
2855
2856 (define-markup-command (normal-text layout props arg)
2857   (markup?)
2858   #:category font
2859   "Set all font related properties (except the size) to get the default
2860 normal text font, no matter what font was used earlier.
2861
2862 @lilypond[verbatim,quote]
2863 \\markup {
2864   \\huge \\bold \\sans \\caps {
2865     huge bold sans caps
2866     \\hspace #2
2867     \\normal-text {
2868       huge normal
2869     }
2870     \\hspace #2
2871     as before
2872   }
2873 }
2874 @end lilypond"
2875   ;; ugh - latin1
2876   (interpret-markup layout
2877                     (cons '((font-family . roman) (font-shape . upright)
2878                             (font-series . medium) (font-encoding . latin1))
2879                           props)
2880                     arg))
2881
2882 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2883 ;; symbols.
2884 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2885
2886 (define-markup-command (musicglyph layout props glyph-name)
2887   (string?)
2888   #:category music
2889   "@var{glyph-name} is converted to a musical symbol; for example,
2890 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
2891 the music font.  See @ruser{The Feta font} for a complete listing of
2892 the possible glyphs.
2893
2894 @lilypond[verbatim,quote]
2895 \\markup {
2896   \\musicglyph #\"f\"
2897   \\musicglyph #\"rests.2\"
2898   \\musicglyph #\"clefs.G_change\"
2899 }
2900 @end lilypond"
2901   (let* ((font (ly:paper-get-font layout
2902                                   (cons '((font-encoding . fetaMusic)
2903                                           (font-name . #f))
2904
2905                                         props)))
2906          (glyph (ly:font-get-glyph font glyph-name)))
2907     (if (null? (ly:stencil-expr glyph))
2908         (ly:warning (_ "Cannot find glyph ~a") glyph-name))
2909
2910     glyph))
2911
2912 (define-markup-command (doublesharp layout props)
2913   ()
2914   #:category music
2915   "Draw a double sharp symbol.
2916
2917 @lilypond[verbatim,quote]
2918 \\markup {
2919   \\doublesharp
2920 }
2921 @end lilypond"
2922   (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist ""))))
2923
2924 (define-markup-command (sesquisharp layout props)
2925   ()
2926   #:category music
2927   "Draw a 3/2 sharp symbol.
2928
2929 @lilypond[verbatim,quote]
2930 \\markup {
2931   \\sesquisharp
2932 }
2933 @end lilypond"
2934   (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist ""))))
2935
2936 (define-markup-command (sharp layout props)
2937   ()
2938   #:category music
2939   "Draw a sharp symbol.
2940
2941 @lilypond[verbatim,quote]
2942 \\markup {
2943   \\sharp
2944 }
2945 @end lilypond"
2946   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist ""))))
2947
2948 (define-markup-command (semisharp layout props)
2949   ()
2950   #:category music
2951   "Draw a semisharp symbol.
2952
2953 @lilypond[verbatim,quote]
2954 \\markup {
2955   \\semisharp
2956 }
2957 @end lilypond"
2958   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist ""))))
2959
2960 (define-markup-command (natural layout props)
2961   ()
2962   #:category music
2963   "Draw a natural symbol.
2964
2965 @lilypond[verbatim,quote]
2966 \\markup {
2967   \\natural
2968 }
2969 @end lilypond"
2970   (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist ""))))
2971
2972 (define-markup-command (semiflat layout props)
2973   ()
2974   #:category music
2975   "Draw a semiflat symbol.
2976
2977 @lilypond[verbatim,quote]
2978 \\markup {
2979   \\semiflat
2980 }
2981 @end lilypond"
2982   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist ""))))
2983
2984 (define-markup-command (flat layout props)
2985   ()
2986   #:category music
2987   "Draw a flat symbol.
2988
2989 @lilypond[verbatim,quote]
2990 \\markup {
2991   \\flat
2992 }
2993 @end lilypond"
2994   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist ""))))
2995
2996 (define-markup-command (sesquiflat layout props)
2997   ()
2998   #:category music
2999   "Draw a 3/2 flat symbol.
3000
3001 @lilypond[verbatim,quote]
3002 \\markup {
3003   \\sesquiflat
3004 }
3005 @end lilypond"
3006   (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist ""))))
3007
3008 (define-markup-command (doubleflat layout props)
3009   ()
3010   #:category music
3011   "Draw a double flat symbol.
3012
3013 @lilypond[verbatim,quote]
3014 \\markup {
3015   \\doubleflat
3016 }
3017 @end lilypond"
3018   (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist ""))))
3019
3020 (define-markup-command (with-color layout props color arg)
3021   (color? markup?)
3022   #:category other
3023   "
3024 @cindex coloring text
3025
3026 Draw @var{arg} in color specified by @var{color}.
3027
3028 @lilypond[verbatim,quote]
3029 \\markup {
3030   \\with-color #red
3031   red
3032   \\hspace #2
3033   \\with-color #green
3034   green
3035   \\hspace #2
3036   \\with-color #blue
3037   blue
3038 }
3039 @end lilypond"
3040   (let ((stil (interpret-markup layout props arg)))
3041     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
3042                      (ly:stencil-extent stil X)
3043                      (ly:stencil-extent stil Y))))
3044
3045 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3046 ;; glyphs
3047 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3048
3049 (define-markup-command (arrow-head layout props axis dir filled)
3050   (integer? ly:dir? boolean?)
3051   #:category graphic
3052   "Produce an arrow head in specified direction and axis.
3053 Use the filled head if @var{filled} is specified.
3054 @lilypond[verbatim,quote]
3055 \\markup {
3056   \\fontsize #5 {
3057     \\general-align #Y #DOWN {
3058       \\arrow-head #Y #UP ##t
3059       \\arrow-head #Y #DOWN ##f
3060       \\hspace #2
3061       \\arrow-head #X #RIGHT ##f
3062       \\arrow-head #X #LEFT ##f
3063     }
3064   }
3065 }
3066 @end lilypond"
3067   (let*
3068       ((name (format #f "arrowheads.~a.~a~a"
3069                      (if filled
3070                          "close"
3071                          "open")
3072                      axis
3073                      dir)))
3074     (ly:font-get-glyph
3075      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
3076                                      props))
3077      name)))
3078
3079 (define-markup-command (lookup layout props glyph-name)
3080   (string?)
3081   #:category other
3082   "Lookup a glyph by name.
3083
3084 @lilypond[verbatim,quote]
3085 \\markup {
3086   \\override #'(font-encoding . fetaBraces) {
3087     \\lookup #\"brace200\"
3088     \\hspace #2
3089     \\rotate #180
3090     \\lookup #\"brace180\"
3091   }
3092 }
3093 @end lilypond"
3094   (ly:font-get-glyph (ly:paper-get-font layout props)
3095                      glyph-name))
3096
3097 (define-markup-command (char layout props num)
3098   (integer?)
3099   #:category other
3100   "Produce a single character.  Characters encoded in hexadecimal
3101 format require the prefix @code{#x}.
3102
3103 @lilypond[verbatim,quote]
3104 \\markup {
3105   \\char #65 \\char ##x00a9
3106 }
3107 @end lilypond"
3108   (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num)))
3109
3110 (define number->mark-letter-vector (make-vector 25 #\A))
3111
3112 (do ((i 0 (1+ i))
3113      (j 0 (1+ j)))
3114     ((>= i 26))
3115   (if (= i (- (char->integer #\I) (char->integer #\A)))
3116       (set! i (1+ i)))
3117   (vector-set! number->mark-letter-vector j
3118                (integer->char (+ i (char->integer #\A)))))
3119
3120 (define number->mark-alphabet-vector (list->vector
3121                                       (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
3122
3123 (define (number->markletter-string vec n)
3124   "Double letters for big marks."
3125   (let* ((lst (vector-length vec)))
3126
3127     (if (>= n lst)
3128         (string-append (number->markletter-string vec (1- (quotient n lst)))
3129                        (number->markletter-string vec (remainder n lst)))
3130         (make-string 1 (vector-ref vec n)))))
3131
3132 (define-markup-command (markletter layout props num)
3133   (integer?)
3134   #:category other
3135   "Make a markup letter for @var{num}.  The letters start with A
3136 to@tie{}Z (skipping letter@tie{}I), and continue with double letters.
3137
3138 @lilypond[verbatim,quote]
3139 \\markup {
3140   \\markletter #8
3141   \\hspace #2
3142   \\markletter #26
3143 }
3144 @end lilypond"
3145   (ly:text-interface::interpret-markup layout props
3146                                        (number->markletter-string number->mark-letter-vector num)))
3147
3148 (define-markup-command (markalphabet layout props num)
3149   (integer?)
3150   #:category other
3151   "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
3152 and continue with double letters.
3153
3154 @lilypond[verbatim,quote]
3155 \\markup {
3156   \\markalphabet #8
3157   \\hspace #2
3158   \\markalphabet #26
3159 }
3160 @end lilypond"
3161   (ly:text-interface::interpret-markup layout props
3162                                        (number->markletter-string number->mark-alphabet-vector num)))
3163
3164 (define-public (horizontal-slash-interval num forward number-interval mag)
3165   (if forward
3166       (cond ;; ((= num 6) (interval-widen number-interval (* mag 0.5)))
3167        ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
3168        (else (interval-widen number-interval (* mag 0.25))))
3169       (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
3170             ;; ((= num 5) (interval-widen number-interval (* mag 0.5)))
3171             (else (interval-widen number-interval (* mag 0.25))))
3172       ))
3173
3174 (define-public (adjust-slash-stencil num forward stencil mag)
3175   (if forward
3176       (cond ((= num 2)
3177              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
3178             ((= num 3)
3179              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
3180             ;; ((= num 5)
3181             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
3182             ;; ((= num 7)
3183             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
3184             (else stencil))
3185       (cond ((= num 6)
3186              (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
3187             ;; ((= num 8)
3188             ;;     (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
3189             (else stencil))
3190       )
3191   )
3192
3193 (define (slashed-digit-internal layout props num forward font-size thickness)
3194   (let* ((mag (magstep font-size))
3195          (thickness (* mag
3196                        (ly:output-def-lookup layout 'line-thickness)
3197                        thickness))
3198          ;; backward slashes might use slope and point in the other direction!
3199          (dy (* mag (if forward 0.4 -0.4)))
3200          (number-stencil (interpret-markup layout
3201                                            (prepend-alist-chain 'font-encoding 'fetaText props)
3202                                            (number->string num)))
3203          (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag))
3204          (center (interval-center (ly:stencil-extent number-stencil Y)))
3205          ;; Use the real extents of the slash, not the whole number,
3206          ;; because we might translate the slash later on!
3207          (num-y (interval-widen (cons center center) (abs dy)))
3208          (is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
3209          (slash-stencil (if is-sane
3210                             (make-line-stencil thickness
3211                                                (car num-x) (- (interval-center num-y) dy)
3212                                                (cdr num-x) (+ (interval-center num-y) dy))
3213                             #f)))
3214     (if (ly:stencil? slash-stencil)
3215         (begin
3216           ;; for some numbers we need to shift the slash/backslash up or
3217           ;; down to make the slashed digit look better
3218           (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
3219           (set! number-stencil
3220                 (ly:stencil-add number-stencil slash-stencil)))
3221         (ly:warning "Unable to create slashed digit ~a" num))
3222     number-stencil))
3223
3224
3225 (define-markup-command (slashed-digit layout props num)
3226   (integer?)
3227   #:category other
3228   #:properties ((font-size 0)
3229                 (thickness 1.6))
3230   "
3231 @cindex slashed digits
3232
3233 A feta number, with slash.  This is for use in the context of
3234 figured bass notation.
3235 @lilypond[verbatim,quote]
3236 \\markup {
3237   \\slashed-digit #5
3238   \\hspace #2
3239   \\override #'(thickness . 3)
3240   \\slashed-digit #7
3241 }
3242 @end lilypond"
3243   (slashed-digit-internal layout props num #t font-size thickness))
3244
3245 (define-markup-command (backslashed-digit layout props num)
3246   (integer?)
3247   #:category other
3248   #:properties ((font-size 0)
3249                 (thickness 1.6))
3250   "
3251 @cindex backslashed digits
3252
3253 A feta number, with backslash.  This is for use in the context of
3254 figured bass notation.
3255 @lilypond[verbatim,quote]
3256 \\markup {
3257   \\backslashed-digit #5
3258   \\hspace #2
3259   \\override #'(thickness . 3)
3260   \\backslashed-digit #7
3261 }
3262 @end lilypond"
3263   (slashed-digit-internal layout props num #f font-size thickness))
3264
3265 ;; eyeglasses
3266 (define eyeglassespath
3267   '((moveto 0.42 0.77)
3268     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
3269     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
3270     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
3271     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
3272     (closepath)
3273     (moveto 2.07 0.77)
3274     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
3275     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
3276     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
3277     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
3278     (closepath)
3279     (moveto 1.025 0.935)
3280     (rcurveto 0 0.182 -0.148 0.33 -0.33 0.33)
3281     (rcurveto -0.182 0 -0.33 -0.148 -0.33 -0.33)
3282     (moveto -0.68 0.77)
3283     (rlineto 0.66 1.43)
3284     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)
3285     (moveto 2.07 0.77)
3286     (rlineto 0.66 1.43)
3287     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)))
3288
3289 (define-markup-command (eyeglasses layout props)
3290   ()
3291   #:category other
3292   "Prints out eyeglasses, indicating strongly to look at the conductor.
3293 @lilypond[verbatim,quote]
3294 \\markup { \\eyeglasses }
3295 @end lilypond"
3296   (interpret-markup layout props
3297                     (make-override-markup '(line-cap-style . butt)
3298                                           (make-path-markup 0.15 eyeglassespath))))
3299
3300 (define-markup-command (left-brace layout props size)
3301   (number?)
3302   #:category other
3303   "
3304 A feta brace in point size @var{size}.
3305
3306 @lilypond[verbatim,quote]
3307 \\markup {
3308   \\left-brace #35
3309   \\hspace #2
3310   \\left-brace #45
3311 }
3312 @end lilypond"
3313   (let* ((font (ly:paper-get-font layout
3314                                   (cons '((font-encoding . fetaBraces)
3315                                           (font-name . #f))
3316                                         props)))
3317          (glyph-count (1- (ly:otf-glyph-count font)))
3318          (scale (ly:output-def-lookup layout 'output-scale))
3319          (scaled-size (/ (ly:pt size) scale))
3320          (glyph (lambda (n)
3321                   (ly:font-get-glyph font (string-append "brace"
3322                                                          (number->string n)))))
3323          (get-y-from-brace (lambda (brace)
3324                              (interval-length
3325                               (ly:stencil-extent (glyph brace) Y))))
3326          (find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size))
3327          (glyph-found (glyph find-brace)))
3328
3329     (if (or (null? (ly:stencil-expr glyph-found))
3330             (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y)))
3331             (> scaled-size (interval-length
3332                             (ly:stencil-extent (glyph glyph-count) Y))))
3333         (begin
3334           (ly:warning (_ "no brace found for point size ~S ") size)
3335           (ly:warning (_ "defaulting to ~S pt")
3336                       (/ (* scale (interval-length
3337                                    (ly:stencil-extent glyph-found Y)))
3338                          (ly:pt 1)))))
3339     glyph-found))
3340
3341 (define-markup-command (right-brace layout props size)
3342   (number?)
3343   #:category other
3344   "
3345 A feta brace in point size @var{size}, rotated 180 degrees.
3346
3347 @lilypond[verbatim,quote]
3348 \\markup {
3349   \\right-brace #45
3350   \\hspace #2
3351   \\right-brace #35
3352 }
3353 @end lilypond"
3354   (interpret-markup layout props (markup #:rotate 180 #:left-brace size)))
3355
3356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3357 ;; the note command.
3358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3359
3360 ;; TODO: better syntax.
3361
3362 (define-markup-command (note-by-number layout props log dot-count dir)
3363   (number? number? number?)
3364   #:category music
3365   #:properties ((font-size 0)
3366                 (flag-style '())
3367                 (style '()))
3368   "
3369 @cindex notes within text by log and dot-count
3370
3371 Construct a note symbol, with stem and flag.  By using fractional values for
3372 @var{dir}, longer or shorter stems can be obtained.
3373 Supports all note-head-styles.
3374 Supported flag-styles are @code{default}, @code{old-straight-flag},
3375 @code{modern-straight-flag} and @code{flat-flag}.
3376
3377 @lilypond[verbatim,quote]
3378 \\markup {
3379   \\note-by-number #3 #0 #DOWN
3380   \\hspace #2
3381   \\note-by-number #1 #2 #0.8
3382 }
3383 @end lilypond"
3384   (define (get-glyph-name-candidates dir log style)
3385     (map (lambda (dir-name)
3386            (format #f "noteheads.~a~a" dir-name
3387                    (if (and (symbol? style)
3388                             (not (equal? 'default style)))
3389                        (select-head-glyph style (min log 2))
3390                        (min log 2))))
3391          (list (if (= dir UP) "u" "d")
3392                "s")))
3393
3394   (define (get-glyph-name font cands)
3395     (if (null? cands)
3396         ""
3397         (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
3398             (get-glyph-name font (cdr cands))
3399             (car cands))))
3400
3401   (define (buildflags flag-stencil remain curr-stencil spacing)
3402     ;; Function to recursively create a stencil with @code{remain} flags
3403     ;; from the single-flag stencil @code{curr-stencil}, which is already
3404     ;; translated to the position of the previous flag position.
3405     ;;
3406     ;; Copy and paste from /scm/flag-styles.scm
3407     (if (> remain 0)
3408         (let* ((translated-stencil
3409                 (ly:stencil-translate-axis curr-stencil spacing Y))
3410                (new-stencil (ly:stencil-add flag-stencil translated-stencil)))
3411           (buildflags new-stencil (- remain 1) translated-stencil spacing))
3412         flag-stencil))
3413
3414   (define (straight-flag-mrkp flag-thickness flag-spacing
3415                               upflag-angle upflag-length
3416                               downflag-angle downflag-length
3417                               dir)
3418     ;; Create a stencil for a straight flag.  @var{flag-thickness} and
3419     ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and
3420     ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and
3421     ;; @var{downflag-length} are given in staff spaces.
3422     ;;
3423     ;; All lengths are scaled according to the font size of the note.
3424     ;;
3425     ;; From /scm/flag-styles.scm, modified to fit here.
3426
3427     (let* ((stem-up (> dir 0))
3428            ;; scale with the note size
3429            (factor (magstep font-size))
3430            (stem-thickness (* factor 0.1))
3431            (line-thickness (ly:output-def-lookup layout 'line-thickness))
3432            (half-stem-thickness (/ (* stem-thickness line-thickness) 2))
3433            (raw-length (if stem-up upflag-length downflag-length))
3434            (angle (if stem-up upflag-angle downflag-angle))
3435            (flag-length (+ (* raw-length factor) half-stem-thickness))
3436            (flag-end (if (= angle 0)
3437                          (cons flag-length (* half-stem-thickness dir))
3438                          (polar->rectangular flag-length angle)))
3439            (thickness (* flag-thickness factor))
3440            (thickness-offset (cons 0 (* -1 thickness dir)))
3441            (spacing (* -1 flag-spacing factor dir))
3442            (start (cons (- half-stem-thickness) (* half-stem-thickness dir)))
3443            ;; The points of a round-filled-polygon need to be given in
3444            ;; clockwise order, otherwise the polygon will be enlarged by
3445            ;; blot-size*2!
3446            (points (if stem-up
3447                        (list start
3448                              flag-end
3449                              (offset-add flag-end thickness-offset)
3450                              (offset-add start thickness-offset))
3451                        (list start
3452                              (offset-add start thickness-offset)
3453                              (offset-add flag-end thickness-offset)
3454                              flag-end)))
3455            (stencil (ly:round-filled-polygon points half-stem-thickness))
3456            ;; Log for 1/8 is 3, so we need to subtract 3
3457            (flag-stencil (buildflags stencil (- log 3) stencil spacing)))
3458       flag-stencil))
3459
3460   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
3461                                                props)))
3462          (size-factor (magstep font-size))
3463          (blot (ly:output-def-lookup layout 'blot-diameter))
3464          (head-glyph-name
3465           (let ((result (get-glyph-name font
3466                                         (get-glyph-name-candidates
3467                                          (sign dir) log style))))
3468             (if (string-null? result)
3469                 ;; If no glyph name can be found, select default heads.
3470                 ;; Though this usually means an unsupported style has been
3471                 ;; chosen, it also prevents unrelated 'style settings from
3472                 ;; other grobs (e.g., TextSpanner and TimeSignature) leaking
3473                 ;; into markup.
3474                 (get-glyph-name font
3475                                 (get-glyph-name-candidates
3476                                  (sign dir) log 'default))
3477                 result)))
3478          (head-glyph (ly:font-get-glyph font head-glyph-name))
3479          (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural)))
3480          (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
3481          (stem-length (* size-factor (max 3 (- log 1))))
3482          ;; With ancient-flags we want a tighter stem
3483          (stem-thickness (* size-factor (if ancient-flags? 0.1 0.13)))
3484          (stemy (* dir stem-length))
3485          (attach-off (cons (interval-index
3486                             (ly:stencil-extent head-glyph X)
3487                             (* (sign dir) (car attach-indices)))
3488                            ;; fixme, this is inconsistent between X & Y.
3489                            (* (sign dir)
3490                               (interval-index
3491                                (ly:stencil-extent head-glyph Y)
3492                                (cdr attach-indices)))))
3493          ;; For a tighter stem (with ancient-flags) the stem-width has to be
3494          ;; adjusted.
3495          (stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0))
3496          (stem-glyph (and (> log 0)
3497                           (ly:round-filled-box
3498                            (ordered-cons (+ stem-X-corr (car attach-off))
3499                                          (+ stem-X-corr (car attach-off)
3500                                             (* (- (sign dir)) stem-thickness)))
3501                            (cons (min stemy (cdr attach-off))
3502                                  (max stemy (cdr attach-off)))
3503                            (/ stem-thickness 3))))
3504          (dot (ly:font-get-glyph font "dots.dot"))
3505          (dotwid (interval-length (ly:stencil-extent dot X)))
3506          (dots (and (> dot-count 0)
3507                     (apply ly:stencil-add
3508                            (map (lambda (x)
3509                                   (ly:stencil-translate-axis
3510                                    dot (* 2 x dotwid) X))
3511                                 (iota dot-count)))))
3512          ;; Straight-flags. Values taken from /scm/flag-style.scm
3513          (modern-straight-flag (straight-flag-mrkp 0.55 1 -18 1.1 22 1.2 dir))
3514          (old-straight-flag (straight-flag-mrkp 0.55 1 -45 1.2 45 1.4 dir))
3515          (flat-flag (straight-flag-mrkp 0.55 1.0 0 1.0 0 1.0 dir))
3516          ;; Calculate a corrective to avoid a gap between
3517          ;; straight-flags and the stem.
3518          (flag-style-Y-corr (if (or (eq? flag-style 'modern-straight-flag)
3519                                     (eq? flag-style 'old-straight-flag)
3520                                     (eq? flag-style 'flat-flag))
3521                                 (/ blot 10 (* -1 dir))
3522                                 0))
3523          (flaggl (and (> log 2)
3524                       (ly:stencil-translate
3525                        (cond ((eq? flag-style 'modern-straight-flag)
3526                               modern-straight-flag)
3527                              ((eq? flag-style 'old-straight-flag)
3528                               old-straight-flag)
3529                              ((eq? flag-style 'flat-flag)
3530                               flat-flag)
3531                              (else
3532                               (ly:font-get-glyph font
3533                                                  (format #f (if ancient-flags?
3534                                                                 "flags.mensural~a2~a"
3535                                                                 "flags.~a~a")
3536                                                          (if (> dir 0) "u" "d")
3537                                                          log))))
3538                        (cons (+ (car attach-off)
3539                                 ;; For tighter stems (with ancient-flags) the
3540                                 ;; flag has to be adjusted different.
3541                                 (if (and (not ancient-flags?) (< dir 0))
3542                                     stem-thickness
3543                                     0))
3544                              (+ stemy flag-style-Y-corr))))))
3545
3546     ;; If there is a flag on an upstem and the stem is short, move the dots
3547     ;; to avoid the flag.  16th notes get a special case because their flags
3548     ;; hang lower than any other flags.
3549     ;; Not with ancient flags or straight-flags.
3550     (if (and dots (> dir 0) (> log 2)
3551              (or (eq? flag-style 'default) (null? flag-style))
3552              (not ancient-flags?)
3553              (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
3554         (set! dots (ly:stencil-translate-axis dots 0.5 X)))
3555     (if flaggl
3556         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
3557     (if (ly:stencil? stem-glyph)
3558         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
3559         (set! stem-glyph head-glyph))
3560     (if (ly:stencil? dots)
3561         (set! stem-glyph
3562               (ly:stencil-add
3563                (ly:stencil-translate-axis
3564                 dots
3565                 (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
3566                 X)
3567                stem-glyph)))
3568     stem-glyph))
3569
3570 (define-public log2
3571   (let ((divisor (log 2)))
3572     (lambda (z) (inexact->exact (/ (log z) divisor)))))
3573
3574 (define (parse-simple-duration duration-string)
3575   "Parse the `duration-string', e.g. ''4..'' or ''breve.'',
3576 and return a (log dots) list."
3577   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)")
3578                             duration-string)))
3579     (if (and match (string=? duration-string (match:substring match 0)))
3580         (let ((len (match:substring match 1))
3581               (dots (match:substring match 2)))
3582           (list (cond ((string=? len "breve") -1)
3583                       ((string=? len "longa") -2)
3584                       ((string=? len "maxima") -3)
3585                       (else (log2 (string->number len))))
3586                 (if dots (string-length dots) 0)))
3587         (ly:error (_ "not a valid duration string: ~a") duration-string))))
3588
3589 (define-markup-command (note layout props duration dir)
3590   (string? number?)
3591   #:category music
3592   #:properties (note-by-number-markup)
3593   "
3594 @cindex notes within text by string
3595
3596 This produces a note with a stem pointing in @var{dir} direction, with
3597 the @var{duration} for the note head type and augmentation dots.  For
3598 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
3599 a shortened down stem.
3600
3601 @lilypond[verbatim,quote]
3602 \\markup {
3603   \\override #'(style . cross) {
3604     \\note #\"4..\" #UP
3605   }
3606   \\hspace #2
3607   \\note #\"breve\" #0
3608 }
3609 @end lilypond"
3610   (let ((parsed (parse-simple-duration duration)))
3611     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
3612
3613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3614 ;; the rest command.
3615 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3616
3617 (define-markup-command (rest-by-number layout props log dot-count)
3618   (number? number?)
3619   #:category music
3620   #:properties ((font-size 0)
3621                 (style '())
3622                 (multi-measure-rest #f))
3623   "
3624 @cindex rests or multi-measure-rests within text by log and dot-count
3625
3626 A rest or multi-measure-rest symbol.
3627
3628 @lilypond[verbatim,quote]
3629 \\markup {
3630   \\rest-by-number #3 #2
3631   \\hspace #2
3632   \\rest-by-number #0 #1
3633   \\hspace #2
3634   \\override #'(multi-measure-rest . #t)
3635   \\rest-by-number #0 #0
3636 }
3637 @end lilypond"
3638
3639   (define (get-glyph-name-candidates log style)
3640     (let* (;; Choose the style-string to be added.
3641            ;; If no glyph exists, select others for the specified styles
3642            ;; otherwise defaulting.
3643            (style-strg
3644             (cond (
3645                    ;; 'baroque needs to be special-cased, otherwise
3646                    ;; `select-head-glyph´ would catch neomensural-glyphs for
3647                    ;; this style, if (< log 0).
3648                    (eq? style 'baroque)
3649                    (string-append (number->string log) ""))
3650                   ((eq? style 'petrucci)
3651                    (string-append (number->string log) "mensural"))
3652                   ;; In other cases `select-head-glyph´ from output-lib.scm
3653                   ;; works for rest-glyphs, too.
3654                   ((and (symbol? style) (not (eq? style 'default)))
3655                    (select-head-glyph style log))
3656                   (else log)))
3657            ;; Choose ledgered glyphs for whole and half rest.
3658            ;; Except for the specified styles, logs and MultiMeasureRests.
3659            (ledger-style-rests
3660             (if (and (or (list? style)
3661                          (not (member style
3662                                       '(neomensural mensural petrucci))))
3663                      (not multi-measure-rest)
3664                      (or (= log 0) (= log 1)))
3665                 "o"
3666                 "")))
3667       (format #f "rests.~a~a" style-strg ledger-style-rests)))
3668
3669   (define (get-glyph-name font cands)
3670     (if (ly:stencil-empty? (ly:font-get-glyph font cands))
3671         ""
3672         cands))
3673
3674   (let* ((font
3675           (ly:paper-get-font layout
3676                              (cons '((font-encoding . fetaMusic)) props)))
3677          (rest-glyph-name
3678           (let ((result
3679                  (get-glyph-name font
3680                                  (get-glyph-name-candidates log style))))
3681             (if (string-null? result)
3682                 ;; If no glyph name can be found, select default rests.  Though
3683                 ;; this usually means an unsupported style has been chosen, it
3684                 ;; also prevents unrelated 'style settings from other grobs
3685                 ;; (e.g., TextSpanner and TimeSignature) leaking into markup.
3686                 (get-glyph-name font (get-glyph-name-candidates log 'default))
3687                 result)))
3688          (rest-glyph (ly:font-get-glyph font rest-glyph-name))
3689          (dot (ly:font-get-glyph font "dots.dot"))
3690          (dot-width (interval-length (ly:stencil-extent dot X)))
3691          (dots (and (> dot-count 0)
3692                     (apply ly:stencil-add
3693                            (map (lambda (x)
3694                                   (ly:stencil-translate-axis
3695                                    dot (* 2 x dot-width) X))
3696                                 (iota dot-count))))))
3697
3698     ;; Apart from mensural-, neomensural- and petrucci-style ledgered
3699     ;; glyphs are taken for whole and half rests.
3700     ;; If they are dotted, move the dots in X-direction to avoid collision.
3701     (if (and dots
3702              (< log 2)
3703              (>= log 0)
3704              (not (member style '(neomensural mensural petrucci))))
3705         (set! dots (ly:stencil-translate-axis dots dot-width X)))
3706
3707     ;; Add dots to the rest-glyph.
3708     ;;
3709     ;; Not sure how to vertical align dots.
3710     ;; For now the dots are centered for half, whole or longer rests.
3711     ;; Otherwise placed near the top of the rest.
3712     ;;
3713     ;; Dots for rests with (< log 0) dots are allowed, but not
3714     ;; if multi-measure-rest is set #t.
3715     (if (and (not multi-measure-rest) dots)
3716         (set! rest-glyph
3717               (ly:stencil-add
3718                (ly:stencil-translate
3719                 dots
3720                 (cons
3721                  (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width)
3722                  (if (< log 2)
3723                      (interval-center (ly:stencil-extent rest-glyph Y))
3724                      (- (interval-end (ly:stencil-extent rest-glyph Y))
3725                         (/ (* 2 dot-width) 3)))))
3726                rest-glyph)))
3727     rest-glyph))
3728
3729 (define-markup-command (rest layout props duration)
3730   (string?)
3731   #:category music
3732   #:properties ((style '())
3733                 (multi-measure-rest #f)
3734                 (multi-measure-rest-number #t)
3735                 (word-space 0.6))
3736   "
3737 @cindex rests or multi-measure-rests within text by string
3738
3739 This produces a rest, with the @var{duration} for the rest type and
3740 augmentation dots.
3741 @code{\"breve\"}, @code{\"longa\"} and @code{\"maxima\"} are valid
3742 input-strings.
3743
3744 Printing MultiMeasureRests could be enabled with
3745 @code{\\override #'(multi-measure-rest . #t)}
3746 If MultiMeasureRests are taken, the MultiMeasureRestNumber is printed above.
3747 This is enabled for all styles using default-glyphs.
3748 Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)}
3749
3750 @lilypond[verbatim,quote]
3751 \\markup {
3752   \\rest #\"4..\"
3753   \\hspace #2
3754   \\rest #\"breve\"
3755   \\hspace #2
3756   \\override #'(multi-measure-rest . #t)
3757   {
3758   \\rest #\"7\"
3759   \\hspace #2
3760   \\override #'(multi-measure-rest-number . #f)
3761   \\rest #\"7\"
3762   }
3763 }
3764 @end lilypond"
3765   ;; Get the number of mmr-glyphs.
3766   ;; Store them in a list.
3767   ;; example: (mmr-numbers 25) -> '(3 0 0 1)
3768   (define (mmr-numbers nmbr)
3769     (let* ((8-bar-glyph (floor (/ nmbr 8)))
3770            (8-remainder (remainder nmbr 8))
3771            (4-bar-glyph (floor (/ 8-remainder 4)))
3772            (4-remainder (remainder nmbr 4))
3773            (2-bar-glyph (floor (/ 4-remainder 2)))
3774            (2-remainder (remainder 4-remainder 2))
3775            (1-bar-glyph (floor (/ 2-remainder 1))))
3776       (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph)))
3777
3778   ;; Get the correct mmr-glyphs.
3779   ;; Store them in a list.
3780   ;; example:
3781   ;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0"))
3782   ;; -> ("rests.M3" "rests.M1")
3783   (define (get-mmr-glyphs lst1 lst2)
3784     (define (helper l1 l2 l3)
3785       (if (null? l1)
3786           (reverse l3)
3787           (helper (cdr l1)
3788                   (cdr l2)
3789                   (append (make-list (car l1) (car l2)) l3))))
3790     (helper lst1 lst2 '()))
3791
3792   ;; If duration is not valid, print a warning and return empty-stencil
3793   (if (or (and (not (integer? (car (parse-simple-duration duration))))
3794                (not multi-measure-rest))
3795           (and (= (string-length (car (string-split duration #\. ))) 1)
3796                (= (string->number (car (string-split duration #\. ))) 0)))
3797       (begin
3798         (ly:warning (_ "not a valid duration string: ~a - ignoring") duration)
3799         empty-stencil)
3800       (let* (
3801              ;; For simple rests:
3802              ;; Get a (log dots) list.
3803              (parsed (parse-simple-duration duration))
3804              ;; Create the rest-stencil
3805              (stil
3806               (rest-by-number-markup layout props (car parsed) (cadr parsed)))
3807              ;; For MultiMeasureRests:
3808              ;; Get the duration-part of duration
3809              (dur-part-string (car (string-split duration #\. )))
3810              ;; Get the duration of MMR:
3811              ;; If not a number (eg. "maxima") calculate it.
3812              (mmr-duration
3813               (or (string->number dur-part-string) (expt 2 (abs (car parsed)))))
3814              ;; Get a list of the correct number of each mmr-glyph.
3815              (count-mmr-glyphs-list (mmr-numbers mmr-duration))
3816              ;; Create a list of mmr-stencils,
3817              ;; translating the glyph for a whole rest.
3818              (mmr-stils-list
3819               (map
3820                (lambda (x)
3821                  (let ((single-mmr-stil
3822                         (rest-by-number-markup layout props (* -1 x) 0)))
3823                    (if (= x 0)
3824                        (ly:stencil-translate-axis
3825                         single-mmr-stil
3826                         ;; Ugh, hard-coded, why 1?
3827                         1
3828                         Y)
3829                        single-mmr-stil)))
3830                (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4)))))
3831              ;; Adjust the space between the mmr-glyphs,
3832              ;; if not default-glyphs are used.
3833              (word-space (if (member style
3834                                      '(neomensural mensural petrucci))
3835                              (/ (* word-space 2) 3)
3836                              word-space))
3837              ;; Create the final mmr-stencil
3838              ;; via `stack-stencil-line´ from /scm/markup.scm
3839              (mmr-stil (stack-stencil-line word-space mmr-stils-list)))
3840
3841         ;; Print the number above a multi-measure-rest
3842         ;; Depends on duration, style and multi-measure-rest-number set #t
3843         (if (and multi-measure-rest
3844                  multi-measure-rest-number
3845                  (> mmr-duration 1)
3846                  (not (member style '(neomensural mensural petrucci))))
3847             (let* ((mmr-stil-x-center
3848                     (interval-center (ly:stencil-extent mmr-stil X)))
3849                    (duration-markup
3850                     (markup
3851                      #:fontsize -2
3852                      #:override '(font-encoding . fetaText)
3853                      (number->string mmr-duration)))
3854                    (mmr-number-stil
3855                     (interpret-markup layout props duration-markup))
3856                    (mmr-number-stil-x-center
3857                     (interval-center (ly:stencil-extent mmr-number-stil X))))
3858
3859               (set! mmr-stil (ly:stencil-combine-at-edge
3860                               mmr-stil
3861                               Y UP
3862                               (ly:stencil-translate-axis
3863                                mmr-number-stil
3864                                (- mmr-stil-x-center mmr-number-stil-x-center)
3865                                X)
3866                               ;; Ugh, hardcoded
3867                               0.8))))
3868         (if multi-measure-rest
3869             mmr-stil
3870             stil))))
3871
3872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3873 ;; fermata markup
3874 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3875
3876 (define-markup-command (fermata layout props) ()
3877   #:category music
3878   #:properties ((direction UP))
3879   "Create a fermata glyph.  When @var{direction} is @code{DOWN}, use
3880 an inverted glyph.  Note that within music, one would usually use the
3881 @code{\\fermata} articulation instead of a markup.
3882
3883 @lilypond[verbatim,quote]
3884  { c''1^\\markup \\fermata d''1_\\markup \\fermata }
3885
3886 \\markup { \\fermata \\override #`(direction . ,DOWN) \\fermata }
3887 @end lilypond
3888 "
3889   (interpret-markup layout props
3890                     (if (eqv? direction DOWN)
3891                         (markup #:musicglyph "scripts.dfermata")
3892                         (markup #:musicglyph "scripts.ufermata"))))
3893
3894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3895 ;; translating.
3896 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3897
3898 (define-markup-command (lower layout props amount arg)
3899   (number? markup?)
3900   #:category align
3901   "
3902 @cindex lowering text
3903
3904 Lower @var{arg} by the distance @var{amount}.
3905 A negative @var{amount} indicates raising; see also @code{\\raise}.
3906
3907 @lilypond[verbatim,quote]
3908 \\markup {
3909   one
3910   \\lower #3
3911   two
3912   three
3913 }
3914 @end lilypond"
3915   (ly:stencil-translate-axis (interpret-markup layout props arg)
3916                              (- amount) Y))
3917
3918 (define-markup-command (translate-scaled layout props offset arg)
3919   (number-pair? markup?)
3920   #:category align
3921   #:properties ((font-size 0))
3922   "
3923 @cindex translating text
3924 @cindex scaling text
3925
3926 Translate @var{arg} by @var{offset}, scaling the offset by the
3927 @code{font-size}.
3928
3929 @lilypond[verbatim,quote]
3930 \\markup {
3931   \\fontsize #5 {
3932     * \\translate #'(2 . 3) translate
3933     \\hspace #2
3934     * \\translate-scaled #'(2 . 3) translate-scaled
3935   }
3936 }
3937 @end lilypond"
3938   (let* ((factor (magstep font-size))
3939          (scaled (cons (* factor (car offset))
3940                        (* factor (cdr offset)))))
3941     (ly:stencil-translate (interpret-markup layout props arg)
3942                           scaled)))
3943
3944 (define-markup-command (raise layout props amount arg)
3945   (number? markup?)
3946   #:category align
3947   "
3948 @cindex raising text
3949
3950 Raise @var{arg} by the distance @var{amount}.
3951 A negative @var{amount} indicates lowering, see also @code{\\lower}.
3952
3953 The argument to @code{\\raise} is the vertical displacement amount,
3954 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
3955 raise objects in relation to their surrounding markups.
3956
3957 If the text object itself is positioned above or below the staff, then
3958 @code{\\raise} cannot be used to move it, since the mechanism that
3959 positions it next to the staff cancels any shift made with
3960 @code{\\raise}.  For vertical positioning, use the @code{padding}
3961 and/or @code{extra-offset} properties.
3962
3963 @lilypond[verbatim,quote]
3964 \\markup {
3965   C
3966   \\small
3967   \\bold
3968   \\raise #1.0
3969   9/7+
3970 }
3971 @end lilypond"
3972   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
3973
3974 (define-markup-command (fraction layout props arg1 arg2)
3975   (markup? markup?)
3976   #:category other
3977   #:properties ((font-size 0))
3978   "
3979 @cindex creating text fractions
3980
3981 Make a fraction of two markups.
3982 @lilypond[verbatim,quote]
3983 \\markup {
3984   π ≈
3985   \\fraction 355 113
3986 }
3987 @end lilypond"
3988   (let* ((m1 (interpret-markup layout props arg1))
3989          (m2 (interpret-markup layout props arg2))
3990          (factor (magstep font-size))
3991          (boxdimen (cons (* factor -0.05) (* factor 0.05)))
3992          (padding (* factor 0.2))
3993          (baseline (* factor 0.6))
3994          (offset (* factor 0.75)))
3995     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
3996     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
3997     (let* ((x1 (ly:stencil-extent m1 X))
3998            (x2 (ly:stencil-extent m2 X))
3999            (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
4000            ;; should stack mols separately, to maintain LINE on baseline
4001            (stack (stack-lines DOWN padding baseline (list m1 line m2))))
4002       (set! stack
4003             (ly:stencil-aligned-to stack Y CENTER))
4004       (set! stack
4005             (ly:stencil-aligned-to stack X LEFT))
4006       ;; should have EX dimension
4007       ;; empirical anyway
4008       (ly:stencil-translate-axis stack offset Y))))
4009
4010 (define-markup-command (normal-size-super layout props arg)
4011   (markup?)
4012   #:category font
4013   #:properties ((font-size 0))
4014   "
4015 @cindex setting superscript in standard font size
4016
4017 Set @var{arg} in superscript with a normal font size.
4018
4019 @lilypond[verbatim,quote]
4020 \\markup {
4021   default
4022   \\normal-size-super {
4023     superscript in standard size
4024   }
4025 }
4026 @end lilypond"
4027   (ly:stencil-translate-axis
4028    (interpret-markup layout props arg)
4029    (* 1.0 (magstep font-size)) Y))
4030
4031 (define-markup-command (super layout props arg)
4032   (markup?)
4033   #:category font
4034   #:properties ((font-size 0))
4035   "
4036 @cindex superscript text
4037
4038 Set @var{arg} in superscript.
4039
4040 @lilypond[verbatim,quote]
4041 \\markup {
4042   E =
4043   \\concat {
4044     mc
4045     \\super
4046     2
4047   }
4048 }
4049 @end lilypond"
4050   (ly:stencil-translate-axis
4051    (interpret-markup
4052     layout
4053     (cons `((font-size . ,(- font-size 3))) props)
4054     arg)
4055    (* 1.0 (magstep font-size)) ; original font-size
4056    Y))
4057
4058 (define-markup-command (translate layout props offset arg)
4059   (number-pair? markup?)
4060   #:category align
4061   "
4062 @cindex translating text
4063
4064 Translate @var{arg} relative to its surroundings.  @var{offset}
4065 is a pair of numbers representing the displacement in the X and Y axis.
4066
4067 @lilypond[verbatim,quote]
4068 \\markup {
4069   *
4070   \\translate #'(2 . 3)
4071   \\line { translated two spaces right, three up }
4072 }
4073 @end lilypond"
4074   (ly:stencil-translate (interpret-markup layout props arg)
4075                         offset))
4076
4077 (define-markup-command (sub layout props arg)
4078   (markup?)
4079   #:category font
4080   #:properties ((font-size 0))
4081   "
4082 @cindex subscript text
4083
4084 Set @var{arg} in subscript.
4085
4086 @lilypond[verbatim,quote]
4087 \\markup {
4088   \\concat {
4089     H
4090     \\sub {
4091       2
4092     }
4093     O
4094   }
4095 }
4096 @end lilypond"
4097   (ly:stencil-translate-axis
4098    (interpret-markup
4099     layout
4100     (cons `((font-size . ,(- font-size 3))) props)
4101     arg)
4102    (* -0.75 (magstep font-size)) ; original font-size
4103    Y))
4104
4105 (define-markup-command (normal-size-sub layout props arg)
4106   (markup?)
4107   #:category font
4108   #:properties ((font-size 0))
4109   "
4110 @cindex setting subscript in standard font size
4111
4112 Set @var{arg} in subscript with a normal font size.
4113
4114 @lilypond[verbatim,quote]
4115 \\markup {
4116   default
4117   \\normal-size-sub {
4118     subscript in standard size
4119   }
4120 }
4121 @end lilypond"
4122   (ly:stencil-translate-axis
4123    (interpret-markup layout props arg)
4124    (* -0.75 (magstep font-size))
4125    Y))
4126
4127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4128 ;; brackets.
4129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4130
4131 (define-markup-command (hbracket layout props arg)
4132   (markup?)
4133   #:category graphic
4134   "
4135 @cindex placing horizontal brackets around text
4136
4137 Draw horizontal brackets around @var{arg}.
4138
4139 @lilypond[verbatim,quote]
4140 \\markup {
4141   \\hbracket {
4142     \\line {
4143       one two three
4144     }
4145   }
4146 }
4147 @end lilypond"
4148   (let ((th 0.1) ;; todo: take from GROB.
4149         (m (interpret-markup layout props arg)))
4150     (bracketify-stencil m X th (* 2.5 th) th)))
4151
4152 (define-markup-command (bracket layout props arg)
4153   (markup?)
4154   #:category graphic
4155   "
4156 @cindex placing vertical brackets around text
4157
4158 Draw vertical brackets around @var{arg}.
4159
4160 @lilypond[verbatim,quote]
4161 \\markup {
4162   \\bracket {
4163     \\note #\"2.\" #UP
4164   }
4165 }
4166 @end lilypond"
4167   (let ((th 0.1) ;; todo: take from GROB.
4168         (m (interpret-markup layout props arg)))
4169     (bracketify-stencil m Y th (* 2.5 th) th)))
4170
4171 (define-markup-command (parenthesize layout props arg)
4172   (markup?)
4173   #:category graphic
4174   #:properties ((angularity 0)
4175                 (padding)
4176                 (size 1)
4177                 (thickness 1)
4178                 (width 0.25))
4179   "
4180 @cindex placing parentheses around text
4181
4182 Draw parentheses around @var{arg}.  This is useful for parenthesizing
4183 a column containing several lines of text.
4184
4185 @lilypond[verbatim,quote]
4186 \\markup {
4187   \\line {
4188     \\parenthesize {
4189       \\column {
4190         foo
4191         bar
4192       }
4193     }
4194     \\override #'(angularity . 2) {
4195       \\parenthesize {
4196         \\column {
4197           bah
4198           baz
4199         }
4200       }
4201     }
4202   }
4203 }
4204 @end lilypond"
4205   (let* ((markup (interpret-markup layout props arg))
4206          (scaled-width (* size width))
4207          (scaled-thickness
4208           (* (chain-assoc-get 'line-thickness props 0.1)
4209              thickness))
4210          (half-thickness
4211           (min (* size 0.5 scaled-thickness)
4212                (* (/ 4 3.0) scaled-width)))
4213          (padding (chain-assoc-get 'padding props half-thickness)))
4214     (parenthesize-stencil
4215      markup half-thickness scaled-width angularity padding)))
4216
4217
4218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4219 ;; Delayed markup evaluation
4220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4221
4222 (define-markup-command (page-ref layout props label gauge default)
4223   (symbol? markup? markup?)
4224   #:category other
4225   "
4226 @cindex referencing page numbers in text
4227
4228 Reference to a page number.  @var{label} is the label set on the referenced
4229 page (using the @code{\\label} command), @var{gauge} a markup used to estimate
4230 the maximum width of the page number, and @var{default} the value to display
4231 when @var{label} is not found."
4232   (let* ((gauge-stencil (interpret-markup layout props gauge))
4233          (x-ext (ly:stencil-extent gauge-stencil X))
4234          (y-ext (ly:stencil-extent gauge-stencil Y)))
4235    (ly:stencil-add
4236     (make-transparent-box-stencil x-ext y-ext))
4237     (ly:make-stencil
4238      `(delay-stencil-evaluation
4239        ,(delay (ly:stencil-expr
4240                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
4241                        (page-number (if (list? table)
4242                                         (assoc-get label table)
4243                                         #f))
4244                        (page-markup (if page-number (format #f "~a" page-number) default))
4245                        (page-stencil (interpret-markup layout props page-markup))
4246                        (gap (- (interval-length x-ext)
4247                                (interval-length (ly:stencil-extent page-stencil X)))))
4248                   (interpret-markup layout props
4249                                     (markup #:hspace gap page-markup))))))
4250      x-ext
4251      y-ext)))
4252
4253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4254 ;; scaling
4255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4256
4257 (define-markup-command (scale layout props factor-pair arg)
4258   (number-pair? markup?)
4259   #:category graphic
4260   "
4261 @cindex scaling markup
4262 @cindex mirroring markup
4263
4264 Scale @var{arg}.  @var{factor-pair} is a pair of numbers
4265 representing the scaling-factor in the X and Y axes.
4266 Negative values may be used to produce mirror images.
4267
4268 @lilypond[verbatim,quote]
4269 \\markup {
4270   \\line {
4271     \\scale #'(2 . 1)
4272     stretched
4273     \\scale #'(1 . -1)
4274     mirrored
4275   }
4276 }
4277 @end lilypond"
4278   (let ((stil (interpret-markup layout props arg))
4279         (sx (car factor-pair))
4280         (sy (cdr factor-pair)))
4281     (ly:stencil-scale stil sx sy)))
4282
4283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4284 ;; Repeating
4285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4286
4287 (define-markup-command (pattern layout props count axis space pattern)
4288   (integer? integer? number? markup?)
4289   #:category other
4290   "
4291 Prints @var{count} times a @var{pattern} markup.
4292 Patterns are spaced apart by @var{space}.
4293 Patterns are distributed on @var{axis}.
4294
4295 @lilypond[verbatim, quote]
4296 \\markup \\column {
4297   \"Horizontally repeated :\"
4298   \\pattern #7 #X #2 \\flat
4299   \\null
4300   \"Vertically repeated :\"
4301   \\pattern #3 #Y #0.5 \\flat
4302 }
4303 @end lilypond"
4304   (let ((pattern-width (interval-length
4305                         (ly:stencil-extent (interpret-markup layout props pattern) X)))
4306         (new-props (prepend-alist-chain 'word-space 0 (prepend-alist-chain 'baseline-skip 0 props))))
4307     (let loop ((i (1- count)) (patterns (markup)))
4308       (if (zero? i)
4309           (interpret-markup
4310            layout
4311            new-props
4312            (if (= axis X)
4313                (markup patterns pattern)
4314                (markup #:column (patterns pattern))))
4315           (loop (1- i)
4316                 (if (= axis X)
4317                     (markup patterns pattern #:hspace space)
4318                     (markup #:column (patterns pattern #:vspace space))))))))
4319
4320 (define-markup-command (fill-with-pattern layout props space dir pattern left right)
4321   (number? ly:dir? markup? markup? markup?)
4322   #:category align
4323   #:properties ((word-space)
4324                 (line-width))
4325   "
4326 Put @var{left} and @var{right} in a horizontal line of width @code{line-width}
4327 with a line of markups @var{pattern} in between.
4328 Patterns are spaced apart by @var{space}.
4329 Patterns are aligned to the @var{dir} markup.
4330
4331 @lilypond[verbatim, quote]
4332 \\markup \\column {
4333   \"right-aligned :\"
4334   \\fill-with-pattern #1 #RIGHT . first right
4335   \\fill-with-pattern #1 #RIGHT . second right
4336   \\null
4337   \"center-aligned :\"
4338   \\fill-with-pattern #1.5 #CENTER - left right
4339   \\null
4340   \"left-aligned :\"
4341   \\override #'(line-width . 50)
4342   \\fill-with-pattern #2 #LEFT : left first
4343   \\override #'(line-width . 50)
4344   \\fill-with-pattern #2 #LEFT : left second
4345 }
4346 @end lilypond"
4347   (let* ((pattern-x-extent (ly:stencil-extent (interpret-markup layout props pattern) X))
4348          (pattern-width (interval-length pattern-x-extent))
4349          (left-width (interval-length (ly:stencil-extent (interpret-markup layout props left) X)))
4350          (right-width (interval-length (ly:stencil-extent (interpret-markup layout props right) X)))
4351          (middle-width (max 0 (- line-width (+ (+ left-width right-width) (* word-space 2)))))
4352          (period (+ space pattern-width))
4353          (count (truncate (/ (- middle-width pattern-width) period)))
4354          (x-offset (+ (* (- (- middle-width (* count period)) pattern-width) (/ (1+ dir) 2)) (abs (car pattern-x-extent)))))
4355     (interpret-markup layout props
4356                       (markup left
4357                               #:with-dimensions (cons 0 middle-width) '(0 . 0)
4358                               #:translate (cons x-offset 0)
4359                               #:pattern (1+ count) X space pattern
4360                               right))))
4361
4362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4363 ;; Replacements
4364 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4365
4366 (define-markup-command (replace layout props replacements arg)
4367   (list? markup?)
4368   #:category font
4369   "
4370 Used to automatically replace a string by another in the markup @var{arg}.
4371 Each pair of the alist @var{replacements} specifies what should be replaced.
4372 The @code{key} is the string to be replaced by the @code{value} string.
4373
4374 @lilypond[verbatim, quote]
4375 \\markup \\replace #'((\"thx\" . \"Thanks!\")) thx
4376 @end lilypond"
4377   (interpret-markup
4378    layout
4379    (internal-add-text-replacements
4380     props
4381     replacements)
4382    (markup arg)))
4383
4384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4385 ;; Markup list commands
4386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4387
4388 (define-public (space-lines baseline stils)
4389   (let space-stil ((stils stils)
4390                    (result (list)))
4391     (if (null? stils)
4392         (reverse! result)
4393         (let* ((stil (car stils))
4394                (dy-top (max (- (/ baseline 1.5)
4395                                (interval-bound (ly:stencil-extent stil Y) UP))
4396                             0.0))
4397                (dy-bottom (max (+ (/ baseline 3.0)
4398                                   (interval-bound (ly:stencil-extent stil Y) DOWN))
4399                                0.0))
4400                (new-stil (ly:make-stencil
4401                           (ly:stencil-expr stil)
4402                           (ly:stencil-extent stil X)
4403                           (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN)
4404                                    dy-bottom)
4405                                 (+ (interval-bound (ly:stencil-extent stil Y) UP)
4406                                    dy-top)))))
4407           (space-stil (cdr stils) (cons new-stil result))))))
4408
4409 (define-markup-list-command (justified-lines layout props args)
4410   (markup-list?)
4411   #:properties ((baseline-skip)
4412                 wordwrap-internal-markup-list)
4413   "
4414 @cindex justifying lines of text
4415
4416 Like @code{\\justify}, but return a list of lines instead of a single markup.
4417 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
4418 @var{X}@tie{}is the number of staff spaces."
4419   (space-lines baseline-skip
4420                (interpret-markup-list layout props
4421                                       (make-wordwrap-internal-markup-list #t args))))
4422
4423 (define-markup-list-command (wordwrap-lines layout props args)
4424   (markup-list?)
4425   #:properties ((baseline-skip)
4426                 wordwrap-internal-markup-list)
4427   "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
4428 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
4429 where @var{X} is the number of staff spaces."
4430   (space-lines baseline-skip
4431                (interpret-markup-list layout props
4432                                       (make-wordwrap-internal-markup-list #f args))))
4433
4434 (define-markup-list-command (column-lines layout props args)
4435   (markup-list?)
4436   #:properties ((baseline-skip))
4437   "Like @code{\\column}, but return a list of lines instead of a single markup.
4438 @code{baseline-skip} determines the space between each markup in @var{args}."
4439   (space-lines baseline-skip
4440                (interpret-markup-list layout props args)))
4441
4442 (define-markup-list-command (override-lines layout props new-prop args)
4443   (pair? markup-list?)
4444   "Like @code{\\override}, for markup lists."
4445   (interpret-markup-list layout (cons (list new-prop) props) args))
4446
4447 (define-markup-list-command (map-markup-commands layout props compose args)
4448   (procedure? markup-list?)
4449   "This applies the function @var{compose} to every markup in
4450 @var{args} (including elements of markup list command calls) in order
4451 to produce a new markup list.  Since the return value from a markup
4452 list command call is not a markup list but rather a list of stencils,
4453 this requires passing those stencils off as the results of individual
4454 markup calls.  That way, the results should work out as long as no
4455 markups rely on side effects."
4456   (let ((key (make-symbol "key")))
4457     (catch
4458      key
4459      (lambda ()
4460        ;; if `compose' does not actually interpret its markup
4461        ;; argument, we still need to return a list of stencils,
4462        ;; created from the single returned stencil
4463        (list
4464         (interpret-markup layout props
4465                           (compose
4466                            (make-on-the-fly-markup
4467                             (lambda (layout props m)
4468                               ;; here all effects of `compose' on the
4469                               ;; properties should be visible, so we
4470                               ;; call interpret-markup-list at this
4471                               ;; point of time and harvest its
4472                               ;; stencils
4473                               (throw key
4474                                      (interpret-markup-list
4475                                       layout props args)))
4476                             (make-null-markup))))))
4477      (lambda (key stencils)
4478        (map
4479         (lambda (sten)
4480           (interpret-markup layout props
4481                             (compose (make-stencil-markup sten))))
4482         stencils)))))