scm/define-markup-commands.scm

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