scm/define-markup-commands.scm

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