scm/define-markup-commands.scm

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