scm/define-markup-commands.scm

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