scm/define-markup-commands.scm

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