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