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