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