scm/define-markup-commands.scm

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