scm/define-markup-commands.scm

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