scm/define-markup-commands.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2011  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 '() '(1 . -1) '(1 . -1)))
 115 (define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118 ;; geometric shapes
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120
 121 (define-markup-command (draw-line layout props dest)
 122   (number-pair?)
 123   #:category graphic
 124   #:properties ((thickness 1))
 125   "
 126 @cindex drawing lines within text
 127
 128 A simple line.
 129 @lilypond[verbatim,quote]
 130 \\markup {
 131   \\draw-line #'(4 . 4)
 132   \\override #'(thickness . 5)
 133   \\draw-line #'(-3 . 0)
 134 }
 135 @end lilypond"
 136   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 137                thickness))
 138         (x (car dest))
 139         (y (cdr dest)))
 140     (make-line-stencil th 0 0 x y)))
 141
 142 (define-markup-command (draw-circle layout props radius thickness filled)
 143   (number? number? boolean?)
 144   #:category graphic
 145   "
 146 @cindex drawing circles within text
 147
 148 A circle of radius @var{radius} and thickness @var{thickness},
 149 optionally filled.
 150
 151 @lilypond[verbatim,quote]
 152 \\markup {
 153   \\draw-circle #2 #0.5 ##f
 154   \\hspace #2
 155   \\draw-circle #2 #0 ##t
 156 }
 157 @end lilypond"
 158   (make-circle-stencil radius thickness filled))
 159
 160 (define-markup-command (triangle layout props filled)
 161   (boolean?)
 162   #:category graphic
 163   #:properties ((thickness 0.1)
 164                 (font-size 0)
 165                 (baseline-skip 2))
 166   "
 167 @cindex drawing triangles within text
 168
 169 A triangle, either filled or empty.
 170
 171 @lilypond[verbatim,quote]
 172 \\markup {
 173   \\triangle ##t
 174   \\hspace #2
 175   \\triangle ##f
 176 }
 177 @end lilypond"
 178   (let ((ex (* (magstep font-size) 0.8 baseline-skip)))
 179     (ly:make-stencil
 180      `(polygon '(0.0 0.0
 181                      ,ex 0.0
 182                      ,(* 0.5 ex)
 183                      ,(* 0.86 ex))
 184            ,thickness
 185            ,filled)
 186      (cons 0 ex)
 187      (cons 0 (* .86 ex)))))
 188
 189 (define-markup-command (circle layout props arg)
 190   (markup?)
 191   #:category graphic
 192   #:properties ((thickness 1)
 193                 (font-size 0)
 194                 (circle-padding 0.2))
 195   "
 196 @cindex circling text
 197
 198 Draw a circle around @var{arg}.  Use @code{thickness},
 199 @code{circle-padding} and @code{font-size} properties to determine line
 200 thickness and padding around the markup.
 201
 202 @lilypond[verbatim,quote]
 203 \\markup {
 204   \\circle {
 205     Hi
 206   }
 207 }
 208 @end lilypond"
 209   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 210                thickness))
 211          (pad (* (magstep font-size) circle-padding))
 212          (m (interpret-markup layout props arg)))
 213     (circle-stencil m th pad)))
 214
 215 (define-markup-command (with-url layout props url arg)
 216   (string? markup?)
 217   #:category graphic
 218   "
 219 @cindex inserting URL links into text
 220
 221 Add a link to URL @var{url} around @var{arg}.  This only works in
 222 the PDF backend.
 223
 224 @lilypond[verbatim,quote]
 225 \\markup {
 226   \\with-url #\"http://lilypond.org/web/\" {
 227     LilyPond ... \\italic {
 228       music notation for everyone
 229     }
 230   }
 231 }
 232 @end lilypond"
 233   (let* ((stil (interpret-markup layout props arg))
 234          (xextent (ly:stencil-extent stil X))
 235          (yextent (ly:stencil-extent stil Y))
 236          (old-expr (ly:stencil-expr stil))
 237          (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
 238
 239     (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
 240
 241 (define-markup-command (beam layout props width slope thickness)
 242   (number? number? number?)
 243   #:category graphic
 244   "
 245 @cindex drawing beams within text
 246
 247 Create a beam with the specified parameters.
 248 @lilypond[verbatim,quote]
 249 \\markup {
 250   \\beam #5 #1 #2
 251 }
 252 @end lilypond"
 253   (let* ((y (* slope width))
 254          (yext (cons (min 0 y) (max 0 y)))
 255          (half (/ thickness 2)))
 256
 257     (ly:make-stencil
 258      `(polygon ',(list
 259                   0 (/ thickness -2)
 260                     width (+ (* width slope)  (/ thickness -2))
 261                     width (+ (* width slope)  (/ thickness 2))
 262                     0 (/ thickness 2))
 263                ,(ly:output-def-lookup layout 'blot-diameter)
 264                #t)
 265      (cons 0 width)
 266      (cons (+ (- half) (car yext))
 267            (+ half (cdr yext))))))
 268
 269 (define-markup-command (underline layout props arg)
 270   (markup?)
 271   #:category font
 272   #:properties ((thickness 1) (offset 2))
 273   "
 274 @cindex underlining text
 275
 276 Underline @var{arg}.  Looks at @code{thickness} to determine line
 277 thickness, and @code{offset} to determine line y-offset.
 278
 279 @lilypond[verbatim,quote]
 280 \\markup \\fill-line {
 281   \\underline \"underlined\"
 282   \\override #'(offset . 5)
 283   \\override #'(thickness . 1)
 284   \\underline \"underlined\"
 285   \\override #'(offset . 1)
 286   \\override #'(thickness . 5)
 287   \\underline \"underlined\"
 288 }
 289 @end lilypond"
 290   (let* ((thick (ly:output-def-lookup layout 'line-thickness))
 291          (underline-thick (* thickness thick))
 292          (markup (interpret-markup layout props arg))
 293          (x1 (car (ly:stencil-extent markup X)))
 294          (x2 (cdr (ly:stencil-extent markup X)))
 295          (y (* thick (- offset)))
 296          (line (make-line-stencil underline-thick x1 y x2 y)))
 297     (ly:stencil-add markup line)))
 298
 299 (define-markup-command (box layout props arg)
 300   (markup?)
 301   #:category font
 302   #:properties ((thickness 1)
 303                 (font-size 0)
 304                 (box-padding 0.2))
 305   "
 306 @cindex enclosing text within a box
 307
 308 Draw a box round @var{arg}.  Looks at @code{thickness},
 309 @code{box-padding} and @code{font-size} properties to determine line
 310 thickness and padding around the markup.
 311
 312 @lilypond[verbatim,quote]
 313 \\markup {
 314   \\override #'(box-padding . 0.5)
 315   \\box
 316   \\line { V. S. }
 317 }
 318 @end lilypond"
 319   (let* ((th (* (ly:output-def-lookup layout 'line-thickness)
 320                 thickness))
 321          (pad (* (magstep font-size) box-padding))
 322          (m (interpret-markup layout props arg)))
 323     (box-stencil m th pad)))
 324
 325 (define-markup-command (filled-box layout props xext yext blot)
 326   (number-pair? number-pair? number?)
 327   #:category graphic
 328   "
 329 @cindex drawing solid boxes within text
 330 @cindex drawing boxes with rounded corners
 331
 332 Draw a box with rounded corners of dimensions @var{xext} and
 333 @var{yext}.  For example,
 334 @verbatim
 335 \\filled-box #'(-.3 . 1.8) #'(-.3 . 1.8) #0
 336 @end verbatim
 337 creates a box extending horizontally from -0.3 to 1.8 and
 338 vertically from -0.3 up to 1.8, with corners formed from a
 339 circle of diameter@tie{}0 (i.e., sharp corners).
 340
 341 @lilypond[verbatim,quote]
 342 \\markup {
 343   \\filled-box #'(0 . 4) #'(0 . 4) #0
 344   \\filled-box #'(0 . 2) #'(-4 . 2) #0.4
 345   \\filled-box #'(1 . 8) #'(0 . 7) #0.2
 346   \\with-color #white
 347   \\filled-box #'(-4.5 . -2.5) #'(3.5 . 5.5) #0.7
 348 }
 349 @end lilypond"
 350   (ly:round-filled-box
 351    xext yext blot))
 352
 353 (define-markup-command (rounded-box layout props arg)
 354   (markup?)
 355   #:category graphic
 356   #:properties ((thickness 1)
 357                 (corner-radius 1)
 358                 (font-size 0)
 359                 (box-padding 0.5))
 360   "@cindex enclosing text in a box with rounded corners
 361    @cindex drawing boxes with rounded corners around text
 362 Draw a box with rounded corners around @var{arg}.  Looks at @code{thickness},
 363 @code{box-padding} and @code{font-size} properties to determine line
 364 thickness and padding around the markup; the @code{corner-radius} property
 365 makes it possible to define another shape for the corners (default is 1).
 366
 367 @lilypond[quote,verbatim,relative=2]
 368 c4^\\markup {
 369   \\rounded-box {
 370     Overtura
 371   }
 372 }
 373 c,8. c16 c4 r
 374 @end lilypond"
 375   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 376                thickness))
 377         (pad (* (magstep font-size) box-padding))
 378         (m (interpret-markup layout props arg)))
 379     (ly:stencil-add (rounded-box-stencil m th pad corner-radius)
 380                     m)))
 381
 382 (define-markup-command (rotate layout props ang arg)
 383   (number? markup?)
 384   #:category align
 385   "
 386 @cindex rotating text
 387
 388 Rotate object with @var{ang} degrees around its center.
 389
 390 @lilypond[verbatim,quote]
 391 \\markup {
 392   default
 393   \\hspace #2
 394   \\rotate #45
 395   \\line {
 396     rotated 45°
 397   }
 398 }
 399 @end lilypond"
 400   (let* ((stil (interpret-markup layout props arg)))
 401     (ly:stencil-rotate stil ang 0 0)))
 402
 403 (define-markup-command (whiteout layout props arg)
 404   (markup?)
 405   #:category other
 406   "
 407 @cindex adding a white background to text
 408
 409 Provide a white background for @var{arg}.
 410
 411 @lilypond[verbatim,quote]
 412 \\markup {
 413   \\combine
 414     \\filled-box #'(-1 . 10) #'(-3 . 4) #1
 415     \\whiteout whiteout
 416 }
 417 @end lilypond"
 418   (stencil-whiteout (interpret-markup layout props arg)))
 419
 420 (define-markup-command (pad-markup layout props amount arg)
 421   (number? markup?)
 422   #:category align
 423   "
 424 @cindex padding text
 425 @cindex putting space around text
 426
 427 Add space around a markup object.
 428
 429 @lilypond[verbatim,quote]
 430 \\markup {
 431   \\box {
 432     default
 433   }
 434   \\hspace #2
 435   \\box {
 436     \\pad-markup #1 {
 437       padded
 438     }
 439   }
 440 }
 441 @end lilypond"
 442   (let*
 443       ((stil (interpret-markup layout props arg))
 444        (xext (ly:stencil-extent stil X))
 445        (yext (ly:stencil-extent stil Y)))
 446
 447     (ly:make-stencil
 448      (ly:stencil-expr stil)
 449      (interval-widen xext amount)
 450      (interval-widen yext amount))))
 451
 452 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 453 ;; space
 454 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 455
 456 (define-markup-command (strut layout props)
 457   ()
 458   #:category other
 459   "
 460 @cindex creating vertical spaces in text
 461
 462 Create a box of the same height as the space in the current font."
 463   (let ((m (ly:text-interface::interpret-markup layout props " ")))
 464     (ly:make-stencil (ly:stencil-expr m)
 465                      '(0 . 0)
 466                      (ly:stencil-extent m X)
 467                      )))
 468
 469 ;; todo: fix negative space
 470 (define-markup-command (hspace layout props amount)
 471   (number?)
 472   #:category align
 473   #:properties ((word-space))
 474   "
 475 @cindex creating horizontal spaces in text
 476
 477 Create an invisible object taking up horizontal space @var{amount}.
 478
 479 @lilypond[verbatim,quote]
 480 \\markup {
 481   one
 482   \\hspace #2
 483   two
 484   \\hspace #8
 485   three
 486 }
 487 @end lilypond"
 488   (let ((corrected-space (- amount word-space)))
 489     (if (> corrected-space 0)
 490         (ly:make-stencil "" (cons 0 corrected-space) '(0 . 0))
 491         (ly:make-stencil "" (cons corrected-space corrected-space) '(0 . 0)))))
 492
 493 ;; todo: fix negative space
 494 (define-markup-command (vspace layout props amount)
 495  (number?)
 496  #:category align
 497  "
 498 @cindex creating vertical spaces in text
 499
 500 Create an invisible object taking up vertical space
 501 of @var{amount} multiplied by 3.
 502
 503 @lilypond[verbatim,quote]
 504 \\markup {
 505     \\center-column {
 506     one
 507     \\vspace #2
 508     two
 509     \\vspace #5
 510     three
 511   }
 512 }
 513 @end lilypond"
 514   (let ((amount (* amount 3.0)))
 515     (if (> amount 0)
 516         (ly:make-stencil "" (cons 0 0) (cons 0 amount))
 517         (ly:make-stencil "" (cons 0 0) (cons amount amount)))))
 518
 519
 520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 521 ;; importing graphics.
 522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 523
 524 (define-markup-command (stencil layout props stil)
 525   (ly:stencil?)
 526   #:category other
 527   "
 528 @cindex importing stencils into text
 529
 530 Use a stencil as markup.
 531
 532 @lilypond[verbatim,quote]
 533 \\markup {
 534   \\stencil #(make-circle-stencil 2 0 #t)
 535 }
 536 @end lilypond"
 537   stil)
 538
 539 (define bbox-regexp
 540   (make-regexp "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))
 541
 542 (define (get-postscript-bbox string)
 543   "Extract the bbox from STRING, or return #f if not present."
 544   (let*
 545       ((match (regexp-exec bbox-regexp string)))
 546
 547     (if match
 548         (map (lambda (x)
 549                (string->number (match:substring match x)))
 550              (cdr (iota 5)))
 551
 552         #f)))
 553
 554 (define-markup-command (epsfile layout props axis size file-name)
 555   (number? number? string?)
 556   #:category graphic
 557   "
 558 @cindex inlining an Encapsulated PostScript image
 559
 560 Inline an EPS image.  The image is scaled along @var{axis} to
 561 @var{size}.
 562
 563 @lilypond[verbatim,quote]
 564 \\markup {
 565   \\general-align #Y #DOWN {
 566     \\epsfile #X #20 #\"context-example.eps\"
 567     \\epsfile #Y #20 #\"context-example.eps\"
 568   }
 569 }
 570 @end lilypond"
 571   (if (ly:get-option 'safe)
 572       (interpret-markup layout props "not allowed in safe")
 573       (eps-file->stencil axis size file-name)
 574       ))
 575
 576 (define-markup-command (postscript layout props str)
 577   (string?)
 578   #:category graphic
 579   "
 580 @cindex inserting PostScript directly into text
 581 This inserts @var{str} directly into the output as a PostScript
 582 command string.
 583
 584 @lilypond[verbatim,quote]
 585 ringsps = #\"
 586   0.15 setlinewidth
 587   0.9 0.6 moveto
 588   0.4 0.6 0.5 0 361 arc
 589   stroke
 590   1.0 0.6 0.5 0 361 arc
 591   stroke
 592   \"
 593
 594 rings = \\markup {
 595   \\with-dimensions #'(-0.2 . 1.6) #'(0 . 1.2)
 596   \\postscript #ringsps
 597 }
 598
 599 \\relative c'' {
 600   c2^\\rings
 601   a2_\\rings
 602 }
 603 @end lilypond"
 604   ;; FIXME
 605   (ly:make-stencil
 606    (list 'embedded-ps
 607          (format "
 608 gsave currentpoint translate
 609 0.1 setlinewidth
 610  ~a
 611 grestore
 612 "
 613                  str))
 614    '(0 . 0) '(0 . 0)))
 615
 616 (define-markup-command (path layout props thickness commands) (number? list?)
 617   #:category graphic
 618   #:properties ((line-cap-style 'round)
 619                 (line-join-style 'round)
 620                 (filled #f))
 621   "
 622 @cindex paths, drawing
 623 @cindex drawing paths
 624 Draws a path with line thickness @var{thickness} according to the
 625 directions given in @var{commands}.  @var{commands} is a list of
 626 lists where the @code{car} of each sublist is a drawing command and
 627 the @code{cdr} comprises the associated arguments for each command.
 628
 629 Line-cap styles and line-join styles may be customized by
 630 overriding the @code{line-cap-style} and @code{line-join-style}
 631 properties, respectively.  Available line-cap styles are
 632 @code{'butt}, @code{'round}, and @code{'square}.  Available
 633 line-join styles are @code{'miter}, @code{'round}, and
 634 @code{'bevel}.
 635
 636 The property @code{filled} specifies whether or not the path is
 637 filled with color.
 638
 639 There are seven commands available to use in the list
 640 @code{commands}: @code{moveto}, @code{rmoveto}, @code{lineto},
 641 @code{rlineto}, @code{curveto}, @code{rcurveto}, and
 642 @code{closepath}.  Note that the commands that begin with @emph{r}
 643 are the relative variants of the other three commands.
 644
 645 The commands @code{moveto}, @code{rmoveto}, @code{lineto}, and
 646 @code{rlineto} take 2 arguments; they are the X and Y coordinates
 647 for the destination point.
 648
 649 The commands @code{curveto} and @code{rcurveto} create cubic
 650 Bézier curves, and take 6 arguments; the first two are the X and Y
 651 coordinates for the first control point, the second two are the X
 652 and Y coordinates for the second control point, and the last two
 653 are the X and Y coordinates for the destination point.
 654
 655 The @code{closepath} command takes zero arguments and closes the
 656 current subpath in the active path.
 657
 658 Note that a sequence of commands @emph{must} begin with a
 659 @code{moveto} or @code{rmoveto} to work with the SVG output.
 660
 661 @lilypond[verbatim,quote]
 662 samplePath =
 663   #'((moveto 0 0)
 664      (lineto -1 1)
 665      (lineto 1 1)
 666      (lineto 1 -1)
 667      (curveto -5 -5 -5 5 -1 0)
 668      (closepath))
 669
 670 \\markup {
 671   \\path #0.25 #samplePath
 672 }
 673 @end lilypond"
 674   (let* ((half-thickness (/ thickness 2))
 675          (current-point '(0 . 0))
 676          (set-point (lambda (lst) (set! current-point lst)))
 677          (relative? (lambda (x)
 678                       (string-prefix? "r" (symbol->string (car x)))))
 679          ;; For calculating extents, we want to modify the command
 680          ;; list so that all coordinates are absolute.
 681          (new-commands (map (lambda (x)
 682                               (cond
 683                                 ;; for rmoveto, rlineto
 684                                 ((and (relative? x) (eq? 3 (length x)))
 685                                  (let ((cp (cons
 686                                              (+ (car current-point)
 687                                                 (second x))
 688                                              (+ (cdr current-point)
 689                                                 (third x)))))
 690                                    (set-point cp)
 691                                    (list (car cp)
 692                                          (cdr cp))))
 693                                 ;; for rcurveto
 694                                 ((and (relative? x) (eq? 7 (length x)))
 695                                  (let* ((old-cp current-point)
 696                                         (cp (cons
 697                                               (+ (car old-cp)
 698                                                  (sixth x))
 699                                               (+ (cdr old-cp)
 700                                                  (seventh x)))))
 701                                    (set-point cp)
 702                                    (list (+ (car old-cp) (second x))
 703                                          (+ (cdr old-cp) (third x))
 704                                          (+ (car old-cp) (fourth x))
 705                                          (+ (cdr old-cp) (fifth x))
 706                                          (car cp)
 707                                          (cdr cp))))
 708                                 ;; for moveto, lineto
 709                                 ((eq? 3 (length x))
 710                                  (set-point (cons (second x)
 711                                                   (third x)))
 712                                  (drop x 1))
 713                                 ;; for curveto
 714                                 ((eq? 7 (length x))
 715                                  (set-point (cons (sixth x)
 716                                                   (seventh x)))
 717                                  (drop x 1))
 718                                 ;; keep closepath for filtering;
 719                                 ;; see `without-closepath'.
 720                                 (else x)))
 721                             commands))
 722          ;; path-min-max does not accept 0-arg lists,
 723          ;; and since closepath does not affect extents, filter
 724          ;; out those commands here.
 725          (without-closepath (filter (lambda (x)
 726                                       (not (equal? 'closepath (car x))))
 727                                     new-commands))
 728          (extents (path-min-max
 729                     ;; set the origin to the first moveto
 730                     (list (list-ref (car without-closepath) 0)
 731                           (list-ref (car without-closepath) 1))
 732                     without-closepath))
 733          (X-extent (cons (list-ref extents 0) (list-ref extents 1)))
 734          (Y-extent (cons (list-ref extents 2) (list-ref extents 3)))
 735          (command-list (fold-right append '() commands)))
 736
 737     ;; account for line thickness
 738     (set! X-extent (interval-widen X-extent half-thickness))
 739     (set! Y-extent (interval-widen Y-extent half-thickness))
 740
 741     (ly:make-stencil
 742       `(path ,thickness `(,@',command-list)
 743              ',line-cap-style ',line-join-style ,filled)
 744       X-extent
 745       Y-extent)))
 746
 747 (define-markup-command (score layout props score)
 748   (ly:score?)
 749   #:category music
 750   #:properties ((baseline-skip))
 751   "
 752 @cindex inserting music into text
 753
 754 Inline an image of music.
 755
 756 @lilypond[verbatim,quote]
 757 \\markup {
 758   \\score {
 759     \\new PianoStaff <<
 760       \\new Staff \\relative c' {
 761         \\key f \\major
 762         \\time 3/4
 763         \\mark \\markup { Allegro }
 764         f2\\p( a4)
 765         c2( a4)
 766         bes2( g'4)
 767         f8( e) e4 r
 768       }
 769       \\new Staff \\relative c {
 770         \\clef bass
 771         \\key f \\major
 772         \\time 3/4
 773         f8( a c a c a
 774         f c' es c es c)
 775         f,( bes d bes d bes)
 776         f( g bes g bes g)
 777       }
 778     >>
 779     \\layout {
 780       indent = 0.0\\cm
 781       \\context {
 782         \\Score
 783         \\override RehearsalMark #'break-align-symbols =
 784           #'(time-signature key-signature)
 785         \\override RehearsalMark #'self-alignment-X = #LEFT
 786       }
 787       \\context {
 788         \\Staff
 789         \\override TimeSignature #'break-align-anchor-alignment = #LEFT
 790       }
 791     }
 792   }
 793 }
 794 @end lilypond"
 795   (let ((output (ly:score-embedded-format score layout)))
 796
 797     (if (ly:music-output? output)
 798         (stack-stencils Y DOWN baseline-skip
 799                         (map paper-system-stencil
 800                              (vector->list
 801                               (ly:paper-score-paper-systems output))))
 802         (begin
 803           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
 804           empty-stencil))))
 805
 806 (define-markup-command (null layout props)
 807   ()
 808   #:category other
 809   "
 810 @cindex creating empty text objects
 811
 812 An empty markup with extents of a single point.
 813
 814 @lilypond[verbatim,quote]
 815 \\markup {
 816   \\null
 817 }
 818 @end lilypond"
 819   point-stencil)
 820
 821 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 822 ;; basic formatting.
 823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 824
 825 (define-markup-command (simple layout props str)
 826   (string?)
 827   #:category font
 828   "
 829 @cindex simple text strings
 830
 831 A simple text string; @code{\\markup @{ foo @}} is equivalent with
 832 @code{\\markup @{ \\simple #\"foo\" @}}.
 833
 834 Note: for creating standard text markup or defining new markup commands,
 835 the use of @code{\\simple} is unnecessary.
 836
 837 @lilypond[verbatim,quote]
 838 \\markup {
 839   \\simple #\"simple\"
 840   \\simple #\"text\"
 841   \\simple #\"strings\"
 842 }
 843 @end lilypond"
 844   (interpret-markup layout props str))
 845
 846 (define-markup-command (tied-lyric layout props str)
 847   (string?)
 848   #:category music
 849   "
 850 @cindex simple text strings with tie characters
 851
 852 Like simple-markup, but use tie characters for @q{~} tilde symbols.
 853
 854 @lilypond[verbatim,quote]
 855 \\markup {
 856   \\tied-lyric #\"Lasciate~i monti\"
 857 }
 858 @end lilypond"
 859   (if (string-contains str "~")
 860       (let*
 861           ((parts (string-split str #\~))
 862            (tie-str (ly:wide-char->utf-8 #x203f))
 863            (joined  (list-join parts tie-str))
 864            (join-stencil (interpret-markup layout props tie-str))
 865            )
 866
 867         (interpret-markup layout
 868                           (prepend-alist-chain
 869                            'word-space
 870                            (/ (interval-length (ly:stencil-extent join-stencil X)) -3.5)
 871                            props)
 872                           (make-line-markup joined)))
 873                            ;(map (lambda (s) (interpret-markup layout props s)) parts))
 874       (interpret-markup layout props str)))
 875
 876 (define-public empty-markup
 877   (make-simple-markup ""))
 878
 879 ;; helper for justifying lines.
 880 (define (get-fill-space word-count line-width word-space text-widths)
 881   "Calculate the necessary paddings between each two adjacent texts.
 882   The lengths of all texts are stored in @var{text-widths}.
 883   The normal formula for the padding between texts a and b is:
 884   padding = line-width/(word-count - 1) - (length(a) + length(b))/2
 885   The first and last padding have to be calculated specially using the
 886   whole length of the first or last text.
 887   All paddings are checked to be at least word-space, to ensure that
 888   no texts collide.
 889   Return a list of paddings."
 890   (cond
 891    ((null? text-widths) '())
 892
 893    ;; special case first padding
 894    ((= (length text-widths) word-count)
 895     (cons
 896      (- (- (/ line-width (1- word-count)) (car text-widths))
 897         (/ (car (cdr text-widths)) 2))
 898      (get-fill-space word-count line-width word-space (cdr text-widths))))
 899    ;; special case last padding
 900    ((= (length text-widths) 2)
 901     (list (- (/ line-width (1- word-count))
 902              (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
 903    (else
 904     (let ((default-padding
 905             (- (/ line-width (1- word-count))
 906                (/ (+ (car text-widths) (car (cdr text-widths))) 2))))
 907       (cons
 908        (if (> word-space default-padding)
 909            word-space
 910            default-padding)
 911        (get-fill-space word-count line-width word-space (cdr text-widths)))))))
 912
 913 (define-markup-command (fill-line layout props args)
 914   (markup-list?)
 915   #:category align
 916   #:properties ((text-direction RIGHT)
 917                 (word-space 0.6)
 918                 (line-width #f))
 919   "Put @var{markups} in a horizontal line of width @var{line-width}.
 920 The markups are spaced or flushed to fill the entire line.
 921 If there are no arguments, return an empty stencil.
 922
 923 @lilypond[verbatim,quote]
 924 \\markup {
 925   \\column {
 926     \\fill-line {
 927       Words evenly spaced across the page
 928     }
 929     \\null
 930     \\fill-line {
 931       \\line { Text markups }
 932       \\line {
 933         \\italic { evenly spaced }
 934       }
 935       \\line { across the page }
 936     }
 937   }
 938 }
 939 @end lilypond"
 940   (let* ((orig-stencils (interpret-markup-list layout props args))
 941          (stencils
 942           (map (lambda (stc)
 943                  (if (ly:stencil-empty? stc)
 944                      point-stencil
 945                      stc)) orig-stencils))
 946          (text-widths
 947           (map (lambda (stc)
 948                  (if (ly:stencil-empty? stc)
 949                      0.0
 950                      (interval-length (ly:stencil-extent stc X))))
 951                stencils))
 952          (text-width (apply + text-widths))
 953          (word-count (length stencils))
 954          (line-width (or line-width (ly:output-def-lookup layout 'line-width)))
 955          (fill-space
 956           (cond
 957            ((= word-count 1)
 958             (list
 959              (/ (- line-width text-width) 2)
 960              (/ (- line-width text-width) 2)))
 961            ((= word-count 2)
 962             (list
 963              (- line-width text-width)))
 964            (else
 965             (get-fill-space word-count line-width word-space text-widths))))
 966
 967          (line-contents (if (= word-count 1)
 968                             (list
 969                              point-stencil
 970                              (car stencils)
 971                              point-stencil)
 972                             stencils)))
 973
 974     (if (null? (remove ly:stencil-empty? orig-stencils))
 975         empty-stencil
 976         (begin
 977           (if (= text-direction LEFT)
 978               (set! line-contents (reverse line-contents)))
 979           (set! line-contents
 980                 (stack-stencils-padding-list
 981                  X RIGHT fill-space line-contents))
 982           (if (> word-count 1)
 983               ;; shift s.t. stencils align on the left edge, even if
 984               ;; first stencil had negative X-extent (e.g. center-column)
 985               ;; (if word-count = 1, X-extents are already normalized in
 986               ;; the definition of line-contents)
 987               (set! line-contents
 988                     (ly:stencil-translate-axis
 989                      line-contents
 990                      (- (car (ly:stencil-extent (car stencils) X)))
 991                      X)))
 992           line-contents))))
 993
 994 (define-markup-command (line layout props args)
 995   (markup-list?)
 996   #:category align
 997   #:properties ((word-space)
 998                 (text-direction RIGHT))
 999   "Put @var{args} in a horizontal line.  The property @code{word-space}
1000 determines the space between markups in @var{args}.
1001
1002 @lilypond[verbatim,quote]
1003 \\markup {
1004   \\line {
1005     one two three
1006   }
1007 }
1008 @end lilypond"
1009   (let ((stencils (interpret-markup-list layout props args)))
1010     (if (= text-direction LEFT)
1011         (set! stencils (reverse stencils)))
1012     (stack-stencil-line
1013      word-space
1014      (remove ly:stencil-empty? stencils))))
1015
1016 (define-markup-command (concat layout props args)
1017   (markup-list?)
1018   #:category align
1019   "
1020 @cindex concatenating text
1021 @cindex ligatures in text
1022
1023 Concatenate @var{args} in a horizontal line, without spaces in between.
1024 Strings and simple markups are concatenated on the input level, allowing
1025 ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
1026 equivalent to @code{\"fi\"}.
1027
1028 @lilypond[verbatim,quote]
1029 \\markup {
1030   \\concat {
1031     one
1032     two
1033     three
1034   }
1035 }
1036 @end lilypond"
1037   (define (concat-string-args arg-list)
1038     (fold-right (lambda (arg result-list)
1039                   (let ((result (if (pair? result-list)
1040                                     (car result-list)
1041                                   '())))
1042                     (if (and (pair? arg) (eqv? (car arg) simple-markup))
1043                       (set! arg (cadr arg)))
1044                     (if (and (string? result) (string? arg))
1045                         (cons (string-append arg result) (cdr result-list))
1046                       (cons arg result-list))))
1047                 '()
1048                 arg-list))
1049
1050   (interpret-markup layout
1051                     (prepend-alist-chain 'word-space 0 props)
1052                     (make-line-markup (if (markup-command-list? args)
1053                                           args
1054                                           (concat-string-args args)))))
1055
1056 (define (wordwrap-stencils stencils
1057                            justify base-space line-width text-dir)
1058   "Perform simple wordwrap, return stencil of each line."
1059   (define space (if justify
1060                     ;; justify only stretches lines.
1061                     (* 0.7 base-space)
1062                     base-space))
1063   (define (take-list width space stencils
1064                      accumulator accumulated-width)
1065     "Return (head-list . tail) pair, with head-list fitting into width"
1066     (if (null? stencils)
1067         (cons accumulator stencils)
1068         (let* ((first (car stencils))
1069                (first-wid (cdr (ly:stencil-extent (car stencils) X)))
1070                (newwid (+ space first-wid accumulated-width)))
1071           (if (or (null? accumulator)
1072                   (< newwid width))
1073               (take-list width space
1074                          (cdr stencils)
1075                          (cons first accumulator)
1076                          newwid)
1077               (cons accumulator stencils)))))
1078   (let loop ((lines '())
1079              (todo stencils))
1080     (let* ((line-break (take-list line-width space todo
1081                                   '() 0.0))
1082            (line-stencils (car line-break))
1083            (space-left (- line-width
1084                           (apply + (map (lambda (x) (cdr (ly:stencil-extent x X)))
1085                                         line-stencils))))
1086            (line-word-space (cond ((not justify) space)
1087                                   ;; don't stretch last line of paragraph.
1088                                   ;; hmmm . bug - will overstretch the last line in some case.
1089                                   ((null? (cdr line-break))
1090                                    base-space)
1091                                   ((null? line-stencils) 0.0)
1092                                   ((null? (cdr line-stencils)) 0.0)
1093                                   (else (/ space-left (1- (length line-stencils))))))
1094            (line (stack-stencil-line line-word-space
1095                                      (if (= text-dir RIGHT)
1096                                          (reverse line-stencils)
1097                                          line-stencils))))
1098       (if (pair? (cdr line-break))
1099           (loop (cons line lines)
1100                 (cdr line-break))
1101           (begin
1102             (if (= text-dir LEFT)
1103                 (set! line
1104                       (ly:stencil-translate-axis
1105                        line
1106                        (- line-width (interval-end (ly:stencil-extent line X)))
1107                        X)))
1108             (reverse (cons line lines)))))))
1109
1110 (define-markup-list-command (wordwrap-internal layout props justify args)
1111   (boolean? markup-list?)
1112   #:properties ((line-width #f)
1113                 (word-space)
1114                 (text-direction RIGHT))
1115   "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}."
1116   (wordwrap-stencils (remove ly:stencil-empty?
1117                              (interpret-markup-list layout props args))
1118                      justify
1119                      word-space
1120                      (or line-width
1121                          (ly:output-def-lookup layout 'line-width))
1122                      text-direction))
1123
1124 (define-markup-command (justify layout props args)
1125   (markup-list?)
1126   #:category align
1127   #:properties ((baseline-skip)
1128                 wordwrap-internal-markup-list)
1129   "
1130 @cindex justifying text
1131
1132 Like @code{\\wordwrap}, but with lines stretched to justify the margins.
1133 Use @code{\\override #'(line-width . @var{X})} to set the line width;
1134 @var{X}@tie{}is the number of staff spaces.
1135
1136 @lilypond[verbatim,quote]
1137 \\markup {
1138   \\justify {
1139     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1140     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1141     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1142     laboris nisi ut aliquip ex ea commodo consequat.
1143   }
1144 }
1145 @end lilypond"
1146   (stack-lines DOWN 0.0 baseline-skip
1147                (wordwrap-internal-markup-list layout props #t args)))
1148
1149 (define-markup-command (wordwrap layout props args)
1150   (markup-list?)
1151   #:category align
1152   #:properties ((baseline-skip)
1153                 wordwrap-internal-markup-list)
1154   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
1155 the line width, where @var{X} is the number of staff spaces.
1156
1157 @lilypond[verbatim,quote]
1158 \\markup {
1159   \\wordwrap {
1160     Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
1161     do eiusmod tempor incididunt ut labore et dolore magna aliqua.
1162     Ut enim ad minim veniam, quis nostrud exercitation ullamco
1163     laboris nisi ut aliquip ex ea commodo consequat.
1164   }
1165 }
1166 @end lilypond"
1167   (stack-lines DOWN 0.0 baseline-skip
1168                (wordwrap-internal-markup-list layout props #f args)))
1169
1170 (define-markup-list-command (wordwrap-string-internal layout props justify arg)
1171   (boolean? string?)
1172   #:properties ((line-width)
1173                 (word-space)
1174                 (text-direction RIGHT))
1175   "Internal markup list command used to define @code{\\justify-string} and
1176 @code{\\wordwrap-string}."
1177   (let* ((para-strings (regexp-split
1178                         (string-regexp-substitute
1179                          "\r" "\n"
1180                          (string-regexp-substitute "\r\n" "\n" arg))
1181                         "\n[ \t\n]*\n[ \t\n]*"))
1182          (list-para-words (map (lambda (str)
1183                                  (regexp-split str "[ \t\n]+"))
1184                                para-strings))
1185          (para-lines (map (lambda (words)
1186                             (let* ((stencils
1187                                     (remove ly:stencil-empty?
1188                                             (map (lambda (x)
1189                                                    (interpret-markup layout props x))
1190                                                  words))))
1191                               (wordwrap-stencils stencils
1192                                                  justify word-space
1193                                                  line-width text-direction)))
1194                           list-para-words)))
1195     (apply append para-lines)))
1196
1197 (define-markup-command (wordwrap-string layout props arg)
1198   (string?)
1199   #:category align
1200   #:properties ((baseline-skip)
1201                 wordwrap-string-internal-markup-list)
1202   "Wordwrap a string.  Paragraphs may be separated with double newlines.
1203
1204 @lilypond[verbatim,quote]
1205 \\markup {
1206   \\override #'(line-width . 40)
1207   \\wordwrap-string #\"Lorem ipsum dolor sit amet, consectetur
1208       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1209       et dolore magna aliqua.
1210
1211
1212       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1213       laboris nisi ut aliquip ex ea commodo consequat.
1214
1215
1216       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1217       qui officia deserunt mollit anim id est laborum\"
1218 }
1219 @end lilypond"
1220   (stack-lines DOWN 0.0 baseline-skip
1221                (wordwrap-string-internal-markup-list layout props #f arg)))
1222
1223 (define-markup-command (justify-string layout props arg)
1224   (string?)
1225   #:category align
1226   #:properties ((baseline-skip)
1227                 wordwrap-string-internal-markup-list)
1228   "Justify a string.  Paragraphs may be separated with double newlines
1229
1230 @lilypond[verbatim,quote]
1231 \\markup {
1232   \\override #'(line-width . 40)
1233   \\justify-string #\"Lorem ipsum dolor sit amet, consectetur
1234       adipisicing elit, sed do eiusmod tempor incididunt ut labore
1235       et dolore magna aliqua.
1236
1237
1238       Ut enim ad minim veniam, quis nostrud exercitation ullamco
1239       laboris nisi ut aliquip ex ea commodo consequat.
1240
1241
1242       Excepteur sint occaecat cupidatat non proident, sunt in culpa
1243       qui officia deserunt mollit anim id est laborum\"
1244 }
1245 @end lilypond"
1246   (stack-lines DOWN 0.0 baseline-skip
1247                (wordwrap-string-internal-markup-list layout props #t arg)))
1248
1249 (define-markup-command (wordwrap-field layout props symbol)
1250   (symbol?)
1251   #:category align
1252   "Wordwrap the data which has been assigned to @var{symbol}.
1253
1254 @lilypond[verbatim,quote]
1255 \\header {
1256   title = \"My title\"
1257   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1258     elit, sed do eiusmod tempor incididunt ut labore et dolore magna
1259     aliqua.  Ut enim ad minim veniam, quis nostrud exercitation ullamco
1260     laboris nisi ut aliquip ex ea commodo consequat.\"
1261 }
1262
1263 \\paper {
1264   bookTitleMarkup = \\markup {
1265     \\column {
1266       \\fill-line { \\fromproperty #'header:title }
1267       \\null
1268       \\wordwrap-field #'header:myText
1269     }
1270   }
1271 }
1272
1273 \\markup {
1274   \\null
1275 }
1276 @end lilypond"
1277   (let* ((m (chain-assoc-get symbol props)))
1278     (if (string? m)
1279         (wordwrap-string-markup layout props m)
1280         empty-stencil)))
1281
1282 (define-markup-command (justify-field layout props symbol)
1283   (symbol?)
1284   #:category align
1285   "Justify the data which has been assigned to @var{symbol}.
1286
1287 @lilypond[verbatim,quote]
1288 \\header {
1289   title = \"My title\"
1290   myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing
1291     elit, sed do eiusmod tempor incididunt ut labore et dolore magna
1292     aliqua.  Ut enim ad minim veniam, quis nostrud exercitation ullamco
1293     laboris nisi ut aliquip ex ea commodo consequat.\"
1294 }
1295
1296 \\paper {
1297   bookTitleMarkup = \\markup {
1298     \\column {
1299       \\fill-line { \\fromproperty #'header:title }
1300       \\null
1301       \\justify-field #'header:myText
1302     }
1303   }
1304 }
1305
1306 \\markup {
1307   \\null
1308 }
1309 @end lilypond"
1310   (let* ((m (chain-assoc-get symbol props)))
1311     (if (string? m)
1312         (justify-string-markup layout props m)
1313         empty-stencil)))
1314
1315 (define-markup-command (combine layout props arg1 arg2)
1316   (markup? markup?)
1317   #:category align
1318   "
1319 @cindex merging text
1320
1321 Print two markups on top of each other.
1322
1323 Note: @code{\\combine} cannot take a list of markups enclosed in
1324 curly braces as an argument; the follow example will not compile:
1325
1326 @example
1327 \\combine @{ a list @}
1328 @end example
1329
1330 @lilypond[verbatim,quote]
1331 \\markup {
1332   \\fontsize #5
1333   \\override #'(thickness . 2)
1334   \\combine
1335     \\draw-line #'(0 . 4)
1336     \\arrow-head #Y #DOWN ##f
1337 }
1338 @end lilypond"
1339   (let* ((s1 (interpret-markup layout props arg1))
1340          (s2 (interpret-markup layout props arg2)))
1341     (ly:stencil-add s1 s2)))
1342
1343 ;;
1344 ;; TODO: should extract baseline-skip from each argument somehow..
1345 ;;
1346 (define-markup-command (column layout props args)
1347   (markup-list?)
1348   #:category align
1349   #:properties ((baseline-skip))
1350   "
1351 @cindex stacking text in a column
1352
1353 Stack the markups in @var{args} vertically.  The property
1354 @code{baseline-skip} determines the space between markups
1355 in @var{args}.
1356
1357 @lilypond[verbatim,quote]
1358 \\markup {
1359   \\column {
1360     one
1361     two
1362     three
1363   }
1364 }
1365 @end lilypond"
1366   (let ((arg-stencils (interpret-markup-list layout props args)))
1367     (stack-lines -1 0.0 baseline-skip
1368                  (remove ly:stencil-empty? arg-stencils))))
1369
1370 (define-markup-command (dir-column layout props args)
1371   (markup-list?)
1372   #:category align
1373   #:properties ((direction)
1374                 (baseline-skip))
1375   "
1376 @cindex changing direction of text columns
1377
1378 Make a column of @var{args}, going up or down, depending on the
1379 setting of the @code{direction} layout property.
1380
1381 @lilypond[verbatim,quote]
1382 \\markup {
1383   \\override #`(direction . ,UP) {
1384     \\dir-column {
1385       going up
1386     }
1387   }
1388   \\hspace #1
1389   \\dir-column {
1390     going down
1391   }
1392   \\hspace #1
1393   \\override #'(direction . 1) {
1394     \\dir-column {
1395       going up
1396     }
1397   }
1398 }
1399 @end lilypond"
1400   (stack-lines (if (number? direction) direction -1)
1401                0.0
1402                baseline-skip
1403                (interpret-markup-list layout props args)))
1404
1405 (define (general-column align-dir baseline mols)
1406   "Stack @var{mols} vertically, aligned to  @var{align-dir} horizontally."
1407
1408   (let* ((aligned-mols (map (lambda (x) (ly:stencil-aligned-to x X align-dir)) mols)))
1409     (stack-lines -1 0.0 baseline aligned-mols)))
1410
1411 (define-markup-command (center-column layout props args)
1412   (markup-list?)
1413   #:category align
1414   #:properties ((baseline-skip))
1415   "
1416 @cindex centering a column of text
1417
1418 Put @code{args} in a centered column.
1419
1420 @lilypond[verbatim,quote]
1421 \\markup {
1422   \\center-column {
1423     one
1424     two
1425     three
1426   }
1427 }
1428 @end lilypond"
1429   (general-column CENTER baseline-skip (interpret-markup-list layout props args)))
1430
1431 (define-markup-command (left-column layout props args)
1432   (markup-list?)
1433   #:category align
1434   #:properties ((baseline-skip))
1435  "
1436 @cindex text columns, left-aligned
1437
1438 Put @code{args} in a left-aligned column.
1439
1440 @lilypond[verbatim,quote]
1441 \\markup {
1442   \\left-column {
1443     one
1444     two
1445     three
1446   }
1447 }
1448 @end lilypond"
1449   (general-column LEFT baseline-skip (interpret-markup-list layout props args)))
1450
1451 (define-markup-command (right-column layout props args)
1452   (markup-list?)
1453   #:category align
1454   #:properties ((baseline-skip))
1455  "
1456 @cindex text columns, right-aligned
1457
1458 Put @code{args} in a right-aligned column.
1459
1460 @lilypond[verbatim,quote]
1461 \\markup {
1462   \\right-column {
1463     one
1464     two
1465     three
1466   }
1467 }
1468 @end lilypond"
1469   (general-column RIGHT baseline-skip (interpret-markup-list layout props args)))
1470
1471 (define-markup-command (vcenter layout props arg)
1472   (markup?)
1473   #:category align
1474   "
1475 @cindex vertically centering text
1476
1477 Align @code{arg} to its Y@tie{}center.
1478
1479 @lilypond[verbatim,quote]
1480 \\markup {
1481   one
1482   \\vcenter
1483   two
1484   three
1485 }
1486 @end lilypond"
1487   (let* ((mol (interpret-markup layout props arg)))
1488     (ly:stencil-aligned-to mol Y CENTER)))
1489
1490 (define-markup-command (center-align layout props arg)
1491   (markup?)
1492   #:category align
1493   "
1494 @cindex horizontally centering text
1495
1496 Align @code{arg} to its X@tie{}center.
1497
1498 @lilypond[verbatim,quote]
1499 \\markup {
1500   \\column {
1501     one
1502     \\center-align
1503     two
1504     three
1505   }
1506 }
1507 @end lilypond"
1508   (let* ((mol (interpret-markup layout props arg)))
1509     (ly:stencil-aligned-to mol X CENTER)))
1510
1511 (define-markup-command (right-align layout props arg)
1512   (markup?)
1513   #:category align
1514   "
1515 @cindex right aligning text
1516
1517 Align @var{arg} on its right edge.
1518
1519 @lilypond[verbatim,quote]
1520 \\markup {
1521   \\column {
1522     one
1523     \\right-align
1524     two
1525     three
1526   }
1527 }
1528 @end lilypond"
1529   (let* ((m (interpret-markup layout props arg)))
1530     (ly:stencil-aligned-to m X RIGHT)))
1531
1532 (define-markup-command (left-align layout props arg)
1533   (markup?)
1534   #:category align
1535   "
1536 @cindex left aligning text
1537
1538 Align @var{arg} on its left edge.
1539
1540 @lilypond[verbatim,quote]
1541 \\markup {
1542   \\column {
1543     one
1544     \\left-align
1545     two
1546     three
1547   }
1548 }
1549 @end lilypond"
1550   (let* ((m (interpret-markup layout props arg)))
1551     (ly:stencil-aligned-to m X LEFT)))
1552
1553 (define-markup-command (general-align layout props axis dir arg)
1554   (integer? number? markup?)
1555   #:category align
1556   "
1557 @cindex controlling general text alignment
1558
1559 Align @var{arg} in @var{axis} direction to the @var{dir} side.
1560
1561 @lilypond[verbatim,quote]
1562 \\markup {
1563   \\column {
1564     one
1565     \\general-align #X #LEFT
1566     two
1567     three
1568     \\null
1569     one
1570     \\general-align #X #CENTER
1571     two
1572     three
1573     \\null
1574     \\line {
1575       one
1576       \\general-align #Y #UP
1577       two
1578       three
1579     }
1580     \\null
1581     \\line {
1582       one
1583       \\general-align #Y #3.2
1584       two
1585       three
1586     }
1587   }
1588 }
1589 @end lilypond"
1590   (let* ((m (interpret-markup layout props arg)))
1591     (ly:stencil-aligned-to m axis dir)))
1592
1593 (define-markup-command (halign layout props dir arg)
1594   (number? markup?)
1595   #:category align
1596   "
1597 @cindex setting horizontal text alignment
1598
1599 Set horizontal alignment.  If @var{dir} is @code{-1}, then it is
1600 left-aligned, while @code{+1} is right.  Values in between interpolate
1601 alignment accordingly.
1602
1603 @lilypond[verbatim,quote]
1604 \\markup {
1605   \\column {
1606     one
1607     \\halign #LEFT
1608     two
1609     three
1610     \\null
1611     one
1612     \\halign #CENTER
1613     two
1614     three
1615     \\null
1616     one
1617     \\halign #RIGHT
1618     two
1619     three
1620     \\null
1621     one
1622     \\halign #-5
1623     two
1624     three
1625   }
1626 }
1627 @end lilypond"
1628   (let* ((m (interpret-markup layout props arg)))
1629     (ly:stencil-aligned-to m X dir)))
1630
1631 (define-markup-command (with-dimensions layout props x y arg)
1632   (number-pair? number-pair? markup?)
1633   #:category other
1634   "
1635 @cindex setting extent of text objects
1636
1637 Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}."
1638   (let* ((m (interpret-markup layout props arg)))
1639     (ly:make-stencil (ly:stencil-expr m) x y)))
1640
1641 (define-markup-command (pad-around layout props amount arg)
1642   (number? markup?)
1643   #:category align
1644   "Add padding @var{amount} all around @var{arg}.
1645
1646 @lilypond[verbatim,quote]
1647 \\markup {
1648   \\box {
1649     default
1650   }
1651   \\hspace #2
1652   \\box {
1653     \\pad-around #0.5 {
1654       padded
1655     }
1656   }
1657 }
1658 @end lilypond"
1659   (let* ((m (interpret-markup layout props arg))
1660          (x (ly:stencil-extent m X))
1661          (y (ly:stencil-extent m Y)))
1662     (ly:make-stencil (ly:stencil-expr m)
1663                      (interval-widen x amount)
1664                      (interval-widen y amount))))
1665
1666 (define-markup-command (pad-x layout props amount arg)
1667   (number? markup?)
1668   #:category align
1669   "
1670 @cindex padding text horizontally
1671
1672 Add padding @var{amount} around @var{arg} in the X@tie{}direction.
1673
1674 @lilypond[verbatim,quote]
1675 \\markup {
1676   \\box {
1677     default
1678   }
1679   \\hspace #4
1680   \\box {
1681     \\pad-x #2 {
1682       padded
1683     }
1684   }
1685 }
1686 @end lilypond"
1687   (let* ((m (interpret-markup layout props arg))
1688          (x (ly:stencil-extent m X))
1689          (y (ly:stencil-extent m Y)))
1690     (ly:make-stencil (ly:stencil-expr m)
1691                      (interval-widen x amount)
1692                      y)))
1693
1694 (define-markup-command (put-adjacent layout props axis dir arg1 arg2)
1695   (integer? ly:dir? markup? markup?)
1696   #:category align
1697   "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}."
1698   (let ((m1 (interpret-markup layout props arg1))
1699         (m2 (interpret-markup layout props arg2)))
1700     (ly:stencil-combine-at-edge m1 axis dir m2 0.0)))
1701
1702 (define-markup-command (transparent layout props arg)
1703   (markup?)
1704   #:category other
1705   "Make @var{arg} transparent.
1706
1707 @lilypond[verbatim,quote]
1708 \\markup {
1709   \\transparent {
1710     invisible text
1711   }
1712 }
1713 @end lilypond"
1714   (let* ((m (interpret-markup layout props arg))
1715          (x (ly:stencil-extent m X))
1716          (y (ly:stencil-extent m Y)))
1717     (ly:make-stencil "" x y)))
1718
1719 (define-markup-command (pad-to-box layout props x-ext y-ext arg)
1720   (number-pair? number-pair? markup?)
1721   #:category align
1722   "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space.
1723
1724 @lilypond[verbatim,quote]
1725 \\markup {
1726   \\box {
1727     default
1728   }
1729   \\hspace #4
1730   \\box {
1731     \\pad-to-box #'(0 . 10) #'(0 . 3) {
1732       padded
1733     }
1734   }
1735 }
1736 @end lilypond"
1737   (let* ((m (interpret-markup layout props arg))
1738          (x (ly:stencil-extent m X))
1739          (y (ly:stencil-extent m Y)))
1740     (ly:make-stencil (ly:stencil-expr m)
1741                      (interval-union x-ext x)
1742                      (interval-union y-ext y))))
1743
1744 (define-markup-command (hcenter-in layout props length arg)
1745   (number? markup?)
1746   #:category align
1747   "Center @var{arg} horizontally within a box of extending
1748 @var{length}/2 to the left and right.
1749
1750 @lilypond[quote,verbatim]
1751 \\new StaffGroup <<
1752   \\new Staff {
1753     \\set Staff.instrumentName = \\markup {
1754       \\hcenter-in #12
1755       Oboe
1756     }
1757     c''1
1758   }
1759   \\new Staff {
1760     \\set Staff.instrumentName = \\markup {
1761       \\hcenter-in #12
1762       Bassoon
1763     }
1764     \\clef tenor
1765     c'1
1766   }
1767 >>
1768 @end lilypond"
1769   (interpret-markup layout props
1770                     (make-pad-to-box-markup
1771                      (cons (/ length -2) (/ length 2))
1772                      '(0 . 0)
1773                      (make-center-align-markup arg))))
1774
1775 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1776 ;; property
1777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1778
1779 (define-markup-command (fromproperty layout props symbol)
1780   (symbol?)
1781   #:category other
1782   "Read the @var{symbol} from property settings, and produce a stencil
1783 from the markup contained within.  If @var{symbol} is not defined, it
1784 returns an empty markup.
1785
1786 @lilypond[verbatim,quote]
1787 \\header {
1788   myTitle = \"myTitle\"
1789   title = \\markup {
1790     from
1791     \\italic
1792     \\fromproperty #'header:myTitle
1793   }
1794 }
1795 \\markup {
1796   \\null
1797 }
1798 @end lilypond"
1799   (let ((m (chain-assoc-get symbol props)))
1800     (if (markup? m)
1801         (interpret-markup layout props m)
1802         empty-stencil)))
1803
1804 (define-markup-command (on-the-fly layout props procedure arg)
1805   (symbol? markup?)
1806   #:category other
1807   "Apply the @var{procedure} markup command to @var{arg}.
1808 @var{procedure} should take a single argument."
1809   (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
1810     (set-object-property! anonymous-with-signature
1811                           'markup-signature
1812                           (list markup?))
1813     (interpret-markup layout props (list anonymous-with-signature arg))))
1814
1815 (define-markup-command (override layout props new-prop arg)
1816   (pair? markup?)
1817   #:category other
1818   "
1819 @cindex overriding properties within text markup
1820
1821 Add the argument @var{new-prop} to the property list.  Properties
1822 may be any property supported by @rinternals{font-interface},
1823 @rinternals{text-interface} and
1824 @rinternals{instrument-specific-markup-interface}.
1825
1826 @lilypond[verbatim,quote]
1827 \\markup {
1828   \\line {
1829     \\column {
1830       default
1831       baseline-skip
1832     }
1833     \\hspace #2
1834     \\override #'(baseline-skip . 4) {
1835       \\column {
1836         increased
1837         baseline-skip
1838       }
1839     }
1840   }
1841 }
1842 @end lilypond"
1843   (interpret-markup layout (cons (list new-prop) props) arg))
1844
1845 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1846 ;; files
1847 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1848
1849 (define-markup-command (verbatim-file layout props name)
1850   (string?)
1851   #:category other
1852   "Read the contents of file @var{name}, and include it verbatim.
1853
1854 @lilypond[verbatim,quote]
1855 \\markup {
1856   \\verbatim-file #\"simple.ly\"
1857 }
1858 @end lilypond"
1859   (interpret-markup layout props
1860                     (if  (ly:get-option 'safe)
1861                          "verbatim-file disabled in safe mode"
1862                          (let* ((str (ly:gulp-file name))
1863                                 (lines (string-split str #\nl)))
1864                            (make-typewriter-markup
1865                             (make-column-markup lines))))))
1866
1867 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1868 ;; fonts.
1869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1870
1871
1872 (define-markup-command (smaller layout props arg)
1873   (markup?)
1874   #:category font
1875   "Decrease the font size relative to the current setting.
1876
1877 @lilypond[verbatim,quote]
1878 \\markup {
1879   \\fontsize #3.5 {
1880     some large text
1881     \\hspace #2
1882     \\smaller {
1883       a bit smaller
1884     }
1885     \\hspace #2
1886     more large text
1887   }
1888 }
1889 @end lilypond"
1890   (interpret-markup layout props
1891    `(,fontsize-markup -1 ,arg)))
1892
1893 (define-markup-command (larger layout props arg)
1894   (markup?)
1895   #:category font
1896   "Increase the font size relative to the current setting.
1897
1898 @lilypond[verbatim,quote]
1899 \\markup {
1900   default
1901   \\hspace #2
1902   \\larger
1903   larger
1904 }
1905 @end lilypond"
1906   (interpret-markup layout props
1907    `(,fontsize-markup 1 ,arg)))
1908
1909 (define-markup-command (finger layout props arg)
1910   (markup?)
1911   #:category font
1912   "Set @var{arg} as small numbers.
1913
1914 @lilypond[verbatim,quote]
1915 \\markup {
1916   \\finger {
1917     1 2 3 4 5
1918   }
1919 }
1920 @end lilypond"
1921   (interpret-markup layout
1922                     (cons '((font-size . -5) (font-encoding . fetaText)) props)
1923                     arg))
1924
1925 (define-markup-command (abs-fontsize layout props size arg)
1926   (number? markup?)
1927   #:category font
1928   "Use @var{size} as the absolute font size to display @var{arg}.
1929 Adjusts @code{baseline-skip} and @code{word-space} accordingly.
1930
1931 @lilypond[verbatim,quote]
1932 \\markup {
1933   default text font size
1934   \\hspace #2
1935   \\abs-fontsize #16 { text font size 16 }
1936   \\hspace #2
1937   \\abs-fontsize #12 { text font size 12 }
1938 }
1939 @end lilypond"
1940   (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12))
1941          (text-props (list (ly:output-def-lookup layout 'text-font-defaults)))
1942          (ref-word-space (chain-assoc-get 'word-space text-props 0.6))
1943          (ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
1944          (magnification (/ size ref-size)))
1945     (interpret-markup layout
1946                       (cons `((baseline-skip . ,(* magnification ref-baseline))
1947                               (word-space . ,(* magnification ref-word-space))
1948                               (font-size . ,(magnification->font-size magnification)))
1949                             props)
1950                       arg)))
1951
1952 (define-markup-command (fontsize layout props increment arg)
1953   (number? markup?)
1954   #:category font
1955   #:properties ((font-size 0)
1956                 (word-space 1)
1957                 (baseline-skip 2))
1958   "Add @var{increment} to the font-size.  Adjusts @code{baseline-skip}
1959 accordingly.
1960
1961 @lilypond[verbatim,quote]
1962 \\markup {
1963   default
1964   \\hspace #2
1965   \\fontsize #-1.5
1966   smaller
1967 }
1968 @end lilypond"
1969   (let ((entries (list
1970                   (cons 'baseline-skip (* baseline-skip (magstep increment)))
1971                   (cons 'word-space (* word-space (magstep increment)))
1972                   (cons 'font-size (+ font-size increment)))))
1973     (interpret-markup layout (cons entries props) arg)))
1974
1975 (define-markup-command (magnify layout props sz arg)
1976   (number? markup?)
1977   #:category font
1978   "
1979 @cindex magnifying text
1980
1981 Set the font magnification for its argument.  In the following
1982 example, the middle@tie{}A is 10% larger:
1983
1984 @example
1985 A \\magnify #1.1 @{ A @} A
1986 @end example
1987
1988 Note: Magnification only works if a font name is explicitly selected.
1989 Use @code{\\fontsize} otherwise.
1990
1991 @lilypond[verbatim,quote]
1992 \\markup {
1993   default
1994   \\hspace #2
1995   \\magnify #1.5 {
1996     50% larger
1997   }
1998 }
1999 @end lilypond"
2000   (interpret-markup
2001    layout
2002    (prepend-alist-chain 'font-size (magnification->font-size sz) props)
2003    arg))
2004
2005 (define-markup-command (bold layout props arg)
2006   (markup?)
2007   #:category font
2008   "Switch to bold font-series.
2009
2010 @lilypond[verbatim,quote]
2011 \\markup {
2012   default
2013   \\hspace #2
2014   \\bold
2015   bold
2016 }
2017 @end lilypond"
2018   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
2019
2020 (define-markup-command (sans layout props arg)
2021   (markup?)
2022   #:category font
2023   "Switch to the sans serif font family.
2024
2025 @lilypond[verbatim,quote]
2026 \\markup {
2027   default
2028   \\hspace #2
2029   \\sans {
2030     sans serif
2031   }
2032 }
2033 @end lilypond"
2034   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
2035
2036 (define-markup-command (number layout props arg)
2037   (markup?)
2038   #:category font
2039   "Set font family to @code{number}, which yields the font used for
2040 time signatures and fingerings.  This font contains numbers and
2041 some punctuation; it has no letters.
2042
2043 @lilypond[verbatim,quote]
2044 \\markup {
2045   \\number {
2046     0 1 2 3 4 5 6 7 8 9 . ,
2047   }
2048 }
2049 @end lilypond"
2050   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2051
2052 (define-markup-command (roman layout props arg)
2053   (markup?)
2054   #:category font
2055   "Set font family to @code{roman}.
2056
2057 @lilypond[verbatim,quote]
2058 \\markup {
2059   \\sans \\bold {
2060     sans serif, bold
2061     \\hspace #2
2062     \\roman {
2063       text in roman font family
2064     }
2065     \\hspace #2
2066     return to sans
2067   }
2068 }
2069 @end lilypond"
2070   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
2071
2072 (define-markup-command (huge layout props arg)
2073   (markup?)
2074   #:category font
2075   "Set font size to +2.
2076
2077 @lilypond[verbatim,quote]
2078 \\markup {
2079   default
2080   \\hspace #2
2081   \\huge
2082   huge
2083 }
2084 @end lilypond"
2085   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
2086
2087 (define-markup-command (large layout props arg)
2088   (markup?)
2089   #:category font
2090   "Set font size to +1.
2091
2092 @lilypond[verbatim,quote]
2093 \\markup {
2094   default
2095   \\hspace #2
2096   \\large
2097   large
2098 }
2099 @end lilypond"
2100   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
2101
2102 (define-markup-command (normalsize layout props arg)
2103   (markup?)
2104   #:category font
2105   "Set font size to default.
2106
2107 @lilypond[verbatim,quote]
2108 \\markup {
2109   \\teeny {
2110     this is very small
2111     \\hspace #2
2112     \\normalsize {
2113       normal size
2114     }
2115     \\hspace #2
2116     teeny again
2117   }
2118 }
2119 @end lilypond"
2120   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
2121
2122 (define-markup-command (small layout props arg)
2123   (markup?)
2124   #:category font
2125   "Set font size to -1.
2126
2127 @lilypond[verbatim,quote]
2128 \\markup {
2129   default
2130   \\hspace #2
2131   \\small
2132   small
2133 }
2134 @end lilypond"
2135   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
2136
2137 (define-markup-command (tiny layout props arg)
2138   (markup?)
2139   #:category font
2140   "Set font size to -2.
2141
2142 @lilypond[verbatim,quote]
2143 \\markup {
2144   default
2145   \\hspace #2
2146   \\tiny
2147   tiny
2148 }
2149 @end lilypond"
2150   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
2151
2152 (define-markup-command (teeny layout props arg)
2153   (markup?)
2154   #:category font
2155   "Set font size to -3.
2156
2157 @lilypond[verbatim,quote]
2158 \\markup {
2159   default
2160   \\hspace #2
2161   \\teeny
2162   teeny
2163 }
2164 @end lilypond"
2165   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
2166
2167 (define-markup-command (fontCaps layout props arg)
2168   (markup?)
2169   #:category font
2170   "Set @code{font-shape} to @code{caps}
2171
2172 Note: @code{\\fontCaps} requires the installation and selection of
2173 fonts which support the @code{caps} font shape."
2174   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
2175
2176 ;; Poor man's caps
2177 (define-markup-command (smallCaps layout props arg)
2178   (markup?)
2179   #:category font
2180   "Emit @var{arg} as small caps.
2181
2182 Note: @code{\\smallCaps} does not support accented characters.
2183
2184 @lilypond[verbatim,quote]
2185 \\markup {
2186   default
2187   \\hspace #2
2188   \\smallCaps {
2189     Text in small caps
2190   }
2191 }
2192 @end lilypond"
2193   (define (char-list->markup chars lower)
2194     (let ((final-string (string-upcase (reverse-list->string chars))))
2195       (if lower
2196           (markup #:fontsize -2 final-string)
2197           final-string)))
2198   (define (make-small-caps rest-chars currents current-is-lower prev-result)
2199     (if (null? rest-chars)
2200         (make-concat-markup
2201           (reverse! (cons (char-list->markup currents current-is-lower)
2202                           prev-result)))
2203         (let* ((ch (car rest-chars))
2204                (is-lower (char-lower-case? ch)))
2205           (if (or (and current-is-lower is-lower)
2206                   (and (not current-is-lower) (not is-lower)))
2207               (make-small-caps (cdr rest-chars)
2208                                (cons ch currents)
2209                                is-lower
2210                                prev-result)
2211               (make-small-caps (cdr rest-chars)
2212                                (list ch)
2213                                is-lower
2214                                (if (null? currents)
2215                                    prev-result
2216                                    (cons (char-list->markup
2217                                             currents current-is-lower)
2218                                          prev-result)))))))
2219   (interpret-markup layout props
2220     (if (string? arg)
2221         (make-small-caps (string->list arg) (list) #f (list))
2222         arg)))
2223
2224 (define-markup-command (caps layout props arg)
2225   (markup?)
2226   #:category font
2227   "Copy of the @code{\\smallCaps} command.
2228
2229 @lilypond[verbatim,quote]
2230 \\markup {
2231   default
2232   \\hspace #2
2233   \\caps {
2234     Text in small caps
2235   }
2236 }
2237 @end lilypond"
2238   (interpret-markup layout props (make-smallCaps-markup arg)))
2239
2240 (define-markup-command (dynamic layout props arg)
2241   (markup?)
2242   #:category font
2243   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
2244 @b{z}, @b{p}, and @b{r}.  When producing phrases, like
2245 @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be
2246 done in a different font.  The recommended font for this is bold and italic.
2247 @lilypond[verbatim,quote]
2248 \\markup {
2249   \\dynamic {
2250     sfzp
2251   }
2252 }
2253 @end lilypond"
2254   (interpret-markup
2255    layout (prepend-alist-chain 'font-encoding 'fetaText props) arg))
2256
2257 (define-markup-command (text layout props arg)
2258   (markup?)
2259   #:category font
2260   "Use a text font instead of music symbol or music alphabet font.
2261
2262 @lilypond[verbatim,quote]
2263 \\markup {
2264   \\number {
2265     1, 2,
2266     \\text {
2267       three, four,
2268     }
2269     5
2270   }
2271 }
2272 @end lilypond"
2273
2274   ;; ugh - latin1
2275   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
2276                     arg))
2277
2278 (define-markup-command (italic layout props arg)
2279   (markup?)
2280   #:category font
2281   "Use italic @code{font-shape} for @var{arg}.
2282
2283 @lilypond[verbatim,quote]
2284 \\markup {
2285   default
2286   \\hspace #2
2287   \\italic
2288   italic
2289 }
2290 @end lilypond"
2291   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
2292
2293 (define-markup-command (typewriter layout props arg)
2294   (markup?)
2295   #:category font
2296   "Use @code{font-family} typewriter for @var{arg}.
2297
2298 @lilypond[verbatim,quote]
2299 \\markup {
2300   default
2301   \\hspace #2
2302   \\typewriter
2303   typewriter
2304 }
2305 @end lilypond"
2306   (interpret-markup
2307    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
2308
2309 (define-markup-command (upright layout props arg)
2310   (markup?)
2311   #:category font
2312   "Set @code{font-shape} to @code{upright}.  This is the opposite
2313 of @code{italic}.
2314
2315 @lilypond[verbatim,quote]
2316 \\markup {
2317   \\italic {
2318     italic text
2319     \\hspace #2
2320     \\upright {
2321       upright text
2322     }
2323     \\hspace #2
2324     italic again
2325   }
2326 }
2327 @end lilypond"
2328   (interpret-markup
2329    layout (prepend-alist-chain 'font-shape 'upright props) arg))
2330
2331 (define-markup-command (medium layout props arg)
2332   (markup?)
2333   #:category font
2334   "Switch to medium font-series (in contrast to bold).
2335
2336 @lilypond[verbatim,quote]
2337 \\markup {
2338   \\bold {
2339     some bold text
2340     \\hspace #2
2341     \\medium {
2342       medium font series
2343     }
2344     \\hspace #2
2345     bold again
2346   }
2347 }
2348 @end lilypond"
2349   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
2350                     arg))
2351
2352 (define-markup-command (normal-text layout props arg)
2353   (markup?)
2354   #:category font
2355   "Set all font related properties (except the size) to get the default
2356 normal text font, no matter what font was used earlier.
2357
2358 @lilypond[verbatim,quote]
2359 \\markup {
2360   \\huge \\bold \\sans \\caps {
2361     Some text with font overrides
2362     \\hspace #2
2363     \\normal-text {
2364       Default text, same font-size
2365     }
2366     \\hspace #2
2367     More text as before
2368   }
2369 }
2370 @end lilypond"
2371   ;; ugh - latin1
2372   (interpret-markup layout
2373                     (cons '((font-family . roman) (font-shape . upright)
2374                             (font-series . medium) (font-encoding . latin1))
2375                           props)
2376                     arg))
2377
2378 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2379 ;; symbols.
2380 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2381
2382 (define-markup-command (musicglyph layout props glyph-name)
2383   (string?)
2384   #:category music
2385   "@var{glyph-name} is converted to a musical symbol; for example,
2386 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
2387 the music font.  See @ruser{The Feta font} for a complete listing of
2388 the possible glyphs.
2389
2390 @lilypond[verbatim,quote]
2391 \\markup {
2392   \\musicglyph #\"f\"
2393   \\musicglyph #\"rests.2\"
2394   \\musicglyph #\"clefs.G_change\"
2395 }
2396 @end lilypond"
2397   (let* ((font (ly:paper-get-font layout
2398                                   (cons '((font-encoding . fetaMusic)
2399                                           (font-name . #f))
2400
2401                                                  props)))
2402          (glyph (ly:font-get-glyph font glyph-name)))
2403     (if (null? (ly:stencil-expr glyph))
2404         (ly:warning (_ "Cannot find glyph ~a") glyph-name))
2405
2406     glyph))
2407
2408 (define-markup-command (doublesharp layout props)
2409   ()
2410   #:category music
2411   "Draw a double sharp symbol.
2412
2413 @lilypond[verbatim,quote]
2414 \\markup {
2415   \\doublesharp
2416 }
2417 @end lilypond"
2418   (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist ""))))
2419
2420 (define-markup-command (sesquisharp layout props)
2421   ()
2422   #:category music
2423   "Draw a 3/2 sharp symbol.
2424
2425 @lilypond[verbatim,quote]
2426 \\markup {
2427   \\sesquisharp
2428 }
2429 @end lilypond"
2430   (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist ""))))
2431
2432 (define-markup-command (sharp layout props)
2433   ()
2434   #:category music
2435   "Draw a sharp symbol.
2436
2437 @lilypond[verbatim,quote]
2438 \\markup {
2439   \\sharp
2440 }
2441 @end lilypond"
2442   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist ""))))
2443
2444 (define-markup-command (semisharp layout props)
2445   ()
2446   #:category music
2447   "Draw a semisharp symbol.
2448
2449 @lilypond[verbatim,quote]
2450 \\markup {
2451   \\semisharp
2452 }
2453 @end lilypond"
2454   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist ""))))
2455
2456 (define-markup-command (natural layout props)
2457   ()
2458   #:category music
2459   "Draw a natural symbol.
2460
2461 @lilypond[verbatim,quote]
2462 \\markup {
2463   \\natural
2464 }
2465 @end lilypond"
2466   (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist ""))))
2467
2468 (define-markup-command (semiflat layout props)
2469   ()
2470   #:category music
2471   "Draw a semiflat symbol.
2472
2473 @lilypond[verbatim,quote]
2474 \\markup {
2475   \\semiflat
2476 }
2477 @end lilypond"
2478   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist ""))))
2479
2480 (define-markup-command (flat layout props)
2481   ()
2482   #:category music
2483   "Draw a flat symbol.
2484
2485 @lilypond[verbatim,quote]
2486 \\markup {
2487   \\flat
2488 }
2489 @end lilypond"
2490   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist ""))))
2491
2492 (define-markup-command (sesquiflat layout props)
2493   ()
2494   #:category music
2495   "Draw a 3/2 flat symbol.
2496
2497 @lilypond[verbatim,quote]
2498 \\markup {
2499   \\sesquiflat
2500 }
2501 @end lilypond"
2502   (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist ""))))
2503
2504 (define-markup-command (doubleflat layout props)
2505   ()
2506   #:category music
2507   "Draw a double flat symbol.
2508
2509 @lilypond[verbatim,quote]
2510 \\markup {
2511   \\doubleflat
2512 }
2513 @end lilypond"
2514   (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist ""))))
2515
2516 (define-markup-command (with-color layout props color arg)
2517   (color? markup?)
2518   #:category other
2519   "
2520 @cindex coloring text
2521
2522 Draw @var{arg} in color specified by @var{color}.
2523
2524 @lilypond[verbatim,quote]
2525 \\markup {
2526   \\with-color #red
2527   red
2528   \\hspace #2
2529   \\with-color #green
2530   green
2531   \\hspace #2
2532   \\with-color #blue
2533   blue
2534 }
2535 @end lilypond"
2536   (let ((stil (interpret-markup layout props arg)))
2537     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
2538                      (ly:stencil-extent stil X)
2539                      (ly:stencil-extent stil Y))))
2540
2541 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2542 ;; glyphs
2543 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2544
2545 (define-markup-command (arrow-head layout props axis dir filled)
2546   (integer? ly:dir? boolean?)
2547   #:category graphic
2548   "Produce an arrow head in specified direction and axis.
2549 Use the filled head if @var{filled} is specified.
2550 @lilypond[verbatim,quote]
2551 \\markup {
2552   \\fontsize #5 {
2553     \\general-align #Y #DOWN {
2554       \\arrow-head #Y #UP ##t
2555       \\arrow-head #Y #DOWN ##f
2556       \\hspace #2
2557       \\arrow-head #X #RIGHT ##f
2558       \\arrow-head #X #LEFT ##f
2559     }
2560   }
2561 }
2562 @end lilypond"
2563   (let*
2564       ((name (format "arrowheads.~a.~a~a"
2565                      (if filled
2566                          "close"
2567                          "open")
2568                      axis
2569                      dir)))
2570     (ly:font-get-glyph
2571      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
2572                                      props))
2573      name)))
2574
2575 (define-markup-command (lookup layout props glyph-name)
2576   (string?)
2577   #:category other
2578   "Lookup a glyph by name.
2579
2580 @lilypond[verbatim,quote]
2581 \\markup {
2582   \\override #'(font-encoding . fetaBraces) {
2583     \\lookup #\"brace200\"
2584     \\hspace #2
2585     \\rotate #180
2586     \\lookup #\"brace180\"
2587   }
2588 }
2589 @end lilypond"
2590   (ly:font-get-glyph (ly:paper-get-font layout props)
2591                      glyph-name))
2592
2593 (define-markup-command (char layout props num)
2594   (integer?)
2595   #:category other
2596   "Produce a single character.  Characters encoded in hexadecimal
2597 format require the prefix @code{#x}.
2598
2599 @lilypond[verbatim,quote]
2600 \\markup {
2601   \\char #65 \\char ##x00a9
2602 }
2603 @end lilypond"
2604   (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num)))
2605
2606 (define number->mark-letter-vector (make-vector 25 #\A))
2607
2608 (do ((i 0 (1+ i))
2609      (j 0 (1+ j)))
2610     ((>= i 26))
2611   (if (= i (- (char->integer #\I) (char->integer #\A)))
2612       (set! i (1+ i)))
2613   (vector-set! number->mark-letter-vector j
2614                (integer->char (+ i (char->integer #\A)))))
2615
2616 (define number->mark-alphabet-vector (list->vector
2617   (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
2618
2619 (define (number->markletter-string vec n)
2620   "Double letters for big marks."
2621   (let* ((lst (vector-length vec)))
2622
2623     (if (>= n lst)
2624         (string-append (number->markletter-string vec (1- (quotient n lst)))
2625                        (number->markletter-string vec (remainder n lst)))
2626         (make-string 1 (vector-ref vec n)))))
2627
2628 (define-markup-command (markletter layout props num)
2629   (integer?)
2630   #:category other
2631   "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
2632 (skipping letter@tie{}I), and continue with double letters.
2633
2634 @lilypond[verbatim,quote]
2635 \\markup {
2636   \\markletter #8
2637   \\hspace #2
2638   \\markletter #26
2639 }
2640 @end lilypond"
2641   (ly:text-interface::interpret-markup layout props
2642     (number->markletter-string number->mark-letter-vector num)))
2643
2644 (define-markup-command (markalphabet layout props num)
2645   (integer?)
2646   #:category other
2647    "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
2648 and continue with double letters.
2649
2650 @lilypond[verbatim,quote]
2651 \\markup {
2652   \\markalphabet #8
2653   \\hspace #2
2654   \\markalphabet #26
2655 }
2656 @end lilypond"
2657    (ly:text-interface::interpret-markup layout props
2658      (number->markletter-string number->mark-alphabet-vector num)))
2659
2660 (define-public (horizontal-slash-interval num forward number-interval mag)
2661   (if forward
2662     (cond ;((= num 6) (interval-widen number-interval (* mag 0.5)))
2663           ;((= num 5) (interval-widen number-interval (* mag 0.5)))
2664           (else (interval-widen number-interval (* mag 0.25))))
2665     (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
2666           ;((= num 5) (interval-widen number-interval (* mag 0.5)))
2667           (else (interval-widen number-interval (* mag 0.25))))
2668   ))
2669
2670 (define-public (adjust-slash-stencil num forward stencil mag)
2671   (if forward
2672     (cond ((= num 2)
2673               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
2674           ((= num 3)
2675               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
2676           ;((= num 5)
2677               ;(ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
2678           ;((= num 7)
2679           ;    (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
2680           (else stencil))
2681     (cond ((= num 6)
2682               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
2683           ;((= num 8)
2684           ;    (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
2685           (else stencil))
2686   )
2687 )
2688
2689 (define (slashed-digit-internal layout props num forward font-size thickness)
2690   (let* ((mag (magstep font-size))
2691          (thickness (* mag
2692                        (ly:output-def-lookup layout 'line-thickness)
2693                        thickness))
2694          ; backward slashes might use slope and point in the other direction!
2695          (dy (* mag (if forward 0.4 -0.4)))
2696          (number-stencil (interpret-markup layout
2697                                            (prepend-alist-chain 'font-encoding 'fetaText props)
2698                                            (number->string num)))
2699          (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag))
2700          (center (interval-center (ly:stencil-extent number-stencil Y)))
2701          ; Use the real extents of the slash, not the whole number, because we
2702          ; might translate the slash later on!
2703          (num-y (interval-widen (cons center center) (abs dy)))
2704          (is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
2705          (slash-stencil (if is-sane
2706                             (make-line-stencil thickness
2707                                          (car num-x) (- (interval-center num-y) dy)
2708                                          (cdr num-x) (+ (interval-center num-y) dy))
2709                             #f)))
2710     (if (ly:stencil? slash-stencil)
2711       (begin
2712         ; for some numbers we need to shift the slash/backslash up or down to make
2713         ; the slashed digit look better
2714         (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
2715         (set! number-stencil
2716           (ly:stencil-add number-stencil slash-stencil)))
2717       (ly:warning "Unable to create slashed digit ~a" num))
2718     number-stencil))
2719
2720
2721 (define-markup-command (slashed-digit layout props num)
2722   (integer?)
2723   #:category other
2724   #:properties ((font-size 0)
2725                 (thickness 1.6))
2726   "
2727 @cindex slashed digits
2728
2729 A feta number, with slash.  This is for use in the context of
2730 figured bass notation.
2731 @lilypond[verbatim,quote]
2732 \\markup {
2733   \\slashed-digit #5
2734   \\hspace #2
2735   \\override #'(thickness . 3)
2736   \\slashed-digit #7
2737 }
2738 @end lilypond"
2739   (slashed-digit-internal layout props num #t font-size thickness))
2740
2741 (define-markup-command (backslashed-digit layout props num)
2742   (integer?)
2743   #:category other
2744   #:properties ((font-size 0)
2745                 (thickness 1.6))
2746   "
2747 @cindex backslashed digits
2748
2749 A feta number, with backslash.  This is for use in the context of
2750 figured bass notation.
2751 @lilypond[verbatim,quote]
2752 \\markup {
2753   \\backslashed-digit #5
2754   \\hspace #2
2755   \\override #'(thickness . 3)
2756   \\backslashed-digit #7
2757 }
2758 @end lilypond"
2759   (slashed-digit-internal layout props num #f font-size thickness))
2760
2761 ;; eyeglasses
2762 (define eyeglassespath
2763   '((moveto 0.42 0.77)
2764     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
2765     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
2766     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
2767     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
2768     (closepath)
2769     (moveto 2.07 0.77)
2770     (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55)
2771     (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55)
2772     (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55)
2773     (rcurveto 0.304 0 0.55 0.246 0.55 0.55)
2774     (closepath)
2775     (moveto 1.025 0.935)
2776     (rcurveto 0 0.182 -0.148 0.33 -0.33 0.33)
2777     (rcurveto -0.182 0 -0.33 -0.148 -0.33 -0.33)
2778     (moveto -0.68 0.77)
2779     (rlineto 0.66 1.43)
2780     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)
2781     (moveto 2.07 0.77)
2782     (rlineto 0.66 1.43)
2783     (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33)))
2784
2785 (define-markup-command (eyeglasses layout props)
2786   ()
2787   #:category other
2788   "Prints out eyeglasses, indicating strongly to look at the conductor.
2789 @lilypond[verbatim,quote]
2790 \\markup { \\eyeglasses }
2791 @end lilypond"
2792   (interpret-markup layout props
2793     (make-override-markup '(line-cap-style . butt)
2794       (make-path-markup 0.15 eyeglassespath))))
2795
2796 (define-markup-command (left-brace layout props size)
2797   (number?)
2798   #:category other
2799   "
2800 A feta brace in point size @var{size}.
2801
2802 @lilypond[verbatim,quote]
2803 \\markup {
2804   \\left-brace #35
2805   \\hspace #2
2806   \\left-brace #45
2807 }
2808 @end lilypond"
2809   (let* ((font (ly:paper-get-font layout
2810                                   (cons '((font-encoding . fetaBraces)
2811                                           (font-name . #f))
2812                                         props)))
2813          (glyph-count (1- (ly:otf-glyph-count font)))
2814          (scale (ly:output-def-lookup layout 'output-scale))
2815          (scaled-size (/ (ly:pt size) scale))
2816          (glyph (lambda (n)
2817                   (ly:font-get-glyph font (string-append "brace"
2818                                                          (number->string n)))))
2819          (get-y-from-brace (lambda (brace)
2820                              (interval-length
2821                               (ly:stencil-extent (glyph brace) Y))))
2822          (find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size))
2823          (glyph-found (glyph find-brace)))
2824
2825     (if (or (null? (ly:stencil-expr glyph-found))
2826             (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y)))
2827             (> scaled-size (interval-length
2828                             (ly:stencil-extent (glyph glyph-count) Y))))
2829         (begin
2830           (ly:warning (_ "no brace found for point size ~S ") size)
2831           (ly:warning (_ "defaulting to ~S pt")
2832                       (/ (* scale (interval-length
2833                                    (ly:stencil-extent glyph-found Y)))
2834                          (ly:pt 1)))))
2835     glyph-found))
2836
2837 (define-markup-command (right-brace layout props size)
2838   (number?)
2839   #:category other
2840   "
2841 A feta brace in point size @var{size}, rotated 180 degrees.
2842
2843 @lilypond[verbatim,quote]
2844 \\markup {
2845   \\right-brace #45
2846   \\hspace #2
2847   \\right-brace #35
2848 }
2849 @end lilypond"
2850   (interpret-markup layout props (markup #:rotate 180 #:left-brace size)))
2851
2852 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2853 ;; the note command.
2854 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2855
2856 ;; TODO: better syntax.
2857
2858 (define-markup-command (note-by-number layout props log dot-count dir)
2859   (number? number? number?)
2860   #:category music
2861   #:properties ((font-size 0)
2862                 (style '()))
2863   "
2864 @cindex notes within text by log and dot-count
2865
2866 Construct a note symbol, with stem.  By using fractional values for
2867 @var{dir}, longer or shorter stems can be obtained.
2868
2869 @lilypond[verbatim,quote]
2870 \\markup {
2871   \\note-by-number #3 #0 #DOWN
2872   \\hspace #2
2873   \\note-by-number #1 #2 #0.8
2874 }
2875 @end lilypond"
2876   (define (get-glyph-name-candidates dir log style)
2877     (map (lambda (dir-name)
2878            (format "noteheads.~a~a" dir-name
2879                    (if (and (symbol? style)
2880                             (not (equal? 'default style)))
2881                        (select-head-glyph style (min log 2))
2882                        (min log 2))))
2883          (list (if (= dir UP) "u" "d")
2884                "s")))
2885
2886   (define (get-glyph-name font cands)
2887     (if (null? cands)
2888         ""
2889         (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
2890             (get-glyph-name font (cdr cands))
2891             (car cands))))
2892
2893   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
2894                                                props)))
2895          (size-factor (magstep font-size))
2896          (stem-length (* size-factor (max 3 (- log 1))))
2897          (head-glyph-name
2898           (let ((result (get-glyph-name font (get-glyph-name-candidates
2899                                               (sign dir) log style))))
2900             (if (string-null? result)
2901                 ;; If no glyph name can be found, select default heads.  Though
2902                 ;; this usually means an unsupported style has been chosen, it
2903                 ;; also prevents unrelated 'style settings from other grobs
2904                 ;; (e.g., TextSpanner and TimeSignature) leaking into markup.
2905                 (get-glyph-name font (get-glyph-name-candidates
2906                                       (sign dir) log 'default))
2907                 result)))
2908          (head-glyph (ly:font-get-glyph font head-glyph-name))
2909          (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
2910          (stem-thickness (* size-factor 0.13))
2911          (stemy (* dir stem-length))
2912          (attach-off (cons (interval-index
2913                             (ly:stencil-extent head-glyph X)
2914                             (* (sign dir) (car attach-indices)))
2915                            (* (sign dir) ; fixme, this is inconsistent between X & Y.
2916                               (interval-index
2917                                (ly:stencil-extent head-glyph Y)
2918                                (cdr attach-indices)))))
2919          (stem-glyph (and (> log 0)
2920                           (ly:round-filled-box
2921                            (ordered-cons (car attach-off)
2922                                          (+ (car attach-off)
2923                                             (* (- (sign dir)) stem-thickness)))
2924                            (cons (min stemy (cdr attach-off))
2925                                  (max stemy (cdr attach-off)))
2926                            (/ stem-thickness 3))))
2927
2928          (dot (ly:font-get-glyph font "dots.dot"))
2929          (dotwid (interval-length (ly:stencil-extent dot X)))
2930          (dots (and (> dot-count 0)
2931                     (apply ly:stencil-add
2932                            (map (lambda (x)
2933                                   (ly:stencil-translate-axis
2934                                    dot (* 2 x dotwid) X))
2935                                 (iota dot-count)))))
2936          (flaggl (and (> log 2)
2937                       (ly:stencil-translate
2938                        (ly:font-get-glyph font
2939                                           (string-append "flags."
2940                                                          (if (> dir 0) "u" "d")
2941                                                          (number->string log)))
2942                        (cons (+ (car attach-off) (if (< dir 0)
2943                                                      stem-thickness 0))
2944                              stemy)))))
2945
2946     ;; If there is a flag on an upstem and the stem is short, move the dots
2947     ;; to avoid the flag.  16th notes get a special case because their flags
2948     ;; hang lower than any other flags.
2949     (if (and dots (> dir 0) (> log 2)
2950              (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
2951         (set! dots (ly:stencil-translate-axis dots 0.5 X)))
2952     (if flaggl
2953         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
2954     (if (ly:stencil? stem-glyph)
2955         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
2956         (set! stem-glyph head-glyph))
2957     (if (ly:stencil? dots)
2958         (set! stem-glyph
2959               (ly:stencil-add
2960                (ly:stencil-translate-axis
2961                 dots
2962                 (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
2963                 X)
2964                stem-glyph)))
2965     stem-glyph))
2966
2967 (define-public log2
2968   (let ((divisor (log 2)))
2969     (lambda (z) (inexact->exact (/ (log z) divisor)))))
2970
2971 (define (parse-simple-duration duration-string)
2972   "Parse the `duration-string', e.g. ''4..'' or ''breve.'',
2973 and return a (log dots) list."
2974   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)")
2975                             duration-string)))
2976     (if (and match (string=? duration-string (match:substring match 0)))
2977         (let ((len (match:substring match 1))
2978               (dots (match:substring match 2)))
2979           (list (cond ((string=? len "breve") -1)
2980                       ((string=? len "longa") -2)
2981                       ((string=? len "maxima") -3)
2982                       (else (log2 (string->number len))))
2983                 (if dots (string-length dots) 0)))
2984         (ly:error (_ "not a valid duration string: ~a") duration-string))))
2985
2986 (define-markup-command (note layout props duration dir)
2987   (string? number?)
2988   #:category music
2989   #:properties (note-by-number-markup)
2990   "
2991 @cindex notes within text by string
2992
2993 This produces a note with a stem pointing in @var{dir} direction, with
2994 the @var{duration} for the note head type and augmentation dots.  For
2995 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
2996 a shortened down stem.
2997
2998 @lilypond[verbatim,quote]
2999 \\markup {
3000   \\override #'(style . cross) {
3001     \\note #\"4..\" #UP
3002   }
3003   \\hspace #2
3004   \\note #\"breve\" #0
3005 }
3006 @end lilypond"
3007   (let ((parsed (parse-simple-duration duration)))
3008     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
3009
3010 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3011 ;; translating.
3012 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3013
3014 (define-markup-command (lower layout props amount arg)
3015   (number? markup?)
3016   #:category align
3017   "
3018 @cindex lowering text
3019
3020 Lower @var{arg} by the distance @var{amount}.
3021 A negative @var{amount} indicates raising; see also @code{\\raise}.
3022
3023 @lilypond[verbatim,quote]
3024 \\markup {
3025   one
3026   \\lower #3
3027   two
3028   three
3029 }
3030 @end lilypond"
3031   (ly:stencil-translate-axis (interpret-markup layout props arg)
3032                              (- amount) Y))
3033
3034 (define-markup-command (translate-scaled layout props offset arg)
3035   (number-pair? markup?)
3036   #:category align
3037   #:properties ((font-size 0))
3038   "
3039 @cindex translating text
3040 @cindex scaling text
3041
3042 Translate @var{arg} by @var{offset}, scaling the offset by the
3043 @code{font-size}.
3044
3045 @lilypond[verbatim,quote]
3046 \\markup {
3047   \\fontsize #5 {
3048     * \\translate #'(2 . 3) translate
3049     \\hspace #2
3050     * \\translate-scaled #'(2 . 3) translate-scaled
3051   }
3052 }
3053 @end lilypond"
3054   (let* ((factor (magstep font-size))
3055          (scaled (cons (* factor (car offset))
3056                        (* factor (cdr offset)))))
3057     (ly:stencil-translate (interpret-markup layout props arg)
3058                           scaled)))
3059
3060 (define-markup-command (raise layout props amount arg)
3061   (number? markup?)
3062   #:category align
3063   "
3064 @cindex raising text
3065
3066 Raise @var{arg} by the distance @var{amount}.
3067 A negative @var{amount} indicates lowering, see also @code{\\lower}.
3068
3069 The argument to @code{\\raise} is the vertical displacement amount,
3070 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
3071 raise objects in relation to their surrounding markups.
3072
3073 If the text object itself is positioned above or below the staff, then
3074 @code{\\raise} cannot be used to move it, since the mechanism that
3075 positions it next to the staff cancels any shift made with
3076 @code{\\raise}.  For vertical positioning, use the @code{padding}
3077 and/or @code{extra-offset} properties.
3078
3079 @lilypond[verbatim,quote]
3080 \\markup {
3081   C
3082   \\small
3083   \\bold
3084   \\raise #1.0
3085   9/7+
3086 }
3087 @end lilypond"
3088   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
3089
3090 (define-markup-command (fraction layout props arg1 arg2)
3091   (markup? markup?)
3092   #:category other
3093   #:properties ((font-size 0))
3094   "
3095 @cindex creating text fractions
3096
3097 Make a fraction of two markups.
3098 @lilypond[verbatim,quote]
3099 \\markup {
3100   π ≈
3101   \\fraction 355 113
3102 }
3103 @end lilypond"
3104   (let* ((m1 (interpret-markup layout props arg1))
3105          (m2 (interpret-markup layout props arg2))
3106          (factor (magstep font-size))
3107          (boxdimen (cons (* factor -0.05) (* factor 0.05)))
3108          (padding (* factor 0.2))
3109          (baseline (* factor 0.6))
3110          (offset (* factor 0.75)))
3111     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
3112     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
3113     (let* ((x1 (ly:stencil-extent m1 X))
3114            (x2 (ly:stencil-extent m2 X))
3115            (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
3116            ;; should stack mols separately, to maintain LINE on baseline
3117            (stack (stack-lines DOWN padding baseline (list m1 line m2))))
3118       (set! stack
3119             (ly:stencil-aligned-to stack Y CENTER))
3120       (set! stack
3121             (ly:stencil-aligned-to stack X LEFT))
3122       ;; should have EX dimension
3123       ;; empirical anyway
3124       (ly:stencil-translate-axis stack offset Y))))
3125
3126 (define-markup-command (normal-size-super layout props arg)
3127   (markup?)
3128   #:category font
3129   #:properties ((baseline-skip))
3130   "
3131 @cindex setting superscript in standard font size
3132
3133 Set @var{arg} in superscript with a normal font size.
3134
3135 @lilypond[verbatim,quote]
3136 \\markup {
3137   default
3138   \\normal-size-super {
3139     superscript in standard size
3140   }
3141 }
3142 @end lilypond"
3143   (ly:stencil-translate-axis
3144    (interpret-markup layout props arg)
3145    (* 0.5 baseline-skip) Y))
3146
3147 (define-markup-command (super layout props arg)
3148   (markup?)
3149   #:category font
3150   #:properties ((font-size 0)
3151                 (baseline-skip))
3152   "
3153 @cindex superscript text
3154
3155 Set @var{arg} in superscript.
3156
3157 @lilypond[verbatim,quote]
3158 \\markup {
3159   E =
3160   \\concat {
3161     mc
3162     \\super
3163     2
3164   }
3165 }
3166 @end lilypond"
3167   (ly:stencil-translate-axis
3168    (interpret-markup
3169     layout
3170     (cons `((font-size . ,(- font-size 3))) props)
3171     arg)
3172    (* 0.5 baseline-skip)
3173    Y))
3174
3175 (define-markup-command (translate layout props offset arg)
3176   (number-pair? markup?)
3177   #:category align
3178   "
3179 @cindex translating text
3180
3181 Translate @var{arg} relative to its surroundings.  @var{offset}
3182 is a pair of numbers representing the displacement in the X and Y axis.
3183
3184 @lilypond[verbatim,quote]
3185 \\markup {
3186   *
3187   \\translate #'(2 . 3)
3188   \\line { translated two spaces right, three up }
3189 }
3190 @end lilypond"
3191   (ly:stencil-translate (interpret-markup layout props arg)
3192                         offset))
3193
3194 (define-markup-command (sub layout props arg)
3195   (markup?)
3196   #:category font
3197   #:properties ((font-size 0)
3198                 (baseline-skip))
3199   "
3200 @cindex subscript text
3201
3202 Set @var{arg} in subscript.
3203
3204 @lilypond[verbatim,quote]
3205 \\markup {
3206   \\concat {
3207     H
3208     \\sub {
3209       2
3210     }
3211     O
3212   }
3213 }
3214 @end lilypond"
3215   (ly:stencil-translate-axis
3216    (interpret-markup
3217     layout
3218     (cons `((font-size . ,(- font-size 3))) props)
3219     arg)
3220    (* -0.5 baseline-skip)
3221    Y))
3222
3223 (define-markup-command (normal-size-sub layout props arg)
3224   (markup?)
3225   #:category font
3226   #:properties ((baseline-skip))
3227   "
3228 @cindex setting subscript in standard font size
3229
3230 Set @var{arg} in subscript with a normal font size.
3231
3232 @lilypond[verbatim,quote]
3233 \\markup {
3234   default
3235   \\normal-size-sub {
3236     subscript in standard size
3237   }
3238 }
3239 @end lilypond"
3240   (ly:stencil-translate-axis
3241    (interpret-markup layout props arg)
3242    (* -0.5 baseline-skip)
3243    Y))
3244
3245 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3246 ;; brackets.
3247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3248
3249 (define-markup-command (hbracket layout props arg)
3250   (markup?)
3251   #:category graphic
3252   "
3253 @cindex placing horizontal brackets around text
3254
3255 Draw horizontal brackets around @var{arg}.
3256
3257 @lilypond[verbatim,quote]
3258 \\markup {
3259   \\hbracket {
3260     \\line {
3261       one two three
3262     }
3263   }
3264 }
3265 @end lilypond"
3266   (let ((th 0.1) ;; todo: take from GROB.
3267         (m (interpret-markup layout props arg)))
3268     (bracketify-stencil m X th (* 2.5 th) th)))
3269
3270 (define-markup-command (bracket layout props arg)
3271   (markup?)
3272   #:category graphic
3273   "
3274 @cindex placing vertical brackets around text
3275
3276 Draw vertical brackets around @var{arg}.
3277
3278 @lilypond[verbatim,quote]
3279 \\markup {
3280   \\bracket {
3281     \\note #\"2.\" #UP
3282   }
3283 }
3284 @end lilypond"
3285   (let ((th 0.1) ;; todo: take from GROB.
3286         (m (interpret-markup layout props arg)))
3287     (bracketify-stencil m Y th (* 2.5 th) th)))
3288
3289 (define-markup-command (parenthesize layout props arg)
3290   (markup?)
3291   #:category graphic
3292   #:properties ((angularity 0)
3293                 (padding)
3294                 (size 1)
3295                 (thickness 1)
3296                 (width 0.25))
3297   "
3298 @cindex placing parentheses around text
3299
3300 Draw parentheses around @var{arg}.  This is useful for parenthesizing
3301 a column containing several lines of text.
3302
3303 @lilypond[verbatim,quote]
3304 \\markup {
3305   \\line {
3306     \\parenthesize {
3307       \\column {
3308         foo
3309         bar
3310       }
3311     }
3312     \\override #'(angularity . 2) {
3313       \\parenthesize {
3314         \\column {
3315           bah
3316           baz
3317         }
3318       }
3319     }
3320   }
3321 }
3322 @end lilypond"
3323   (let* ((markup (interpret-markup layout props arg))
3324          (scaled-width (* size width))
3325          (scaled-thickness
3326           (* (chain-assoc-get 'line-thickness props 0.1)
3327              thickness))
3328          (half-thickness
3329           (min (* size 0.5 scaled-thickness)
3330                (* (/ 4 3.0) scaled-width)))
3331          (padding (chain-assoc-get 'padding props half-thickness)))
3332     (parenthesize-stencil
3333      markup half-thickness scaled-width angularity padding)))
3334
3335 \f
3336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3337 ;; Delayed markup evaluation
3338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3339
3340 (define-markup-command (page-ref layout props label gauge default)
3341   (symbol? markup? markup?)
3342   #:category other
3343   "
3344 @cindex referencing page numbers in text
3345
3346 Reference to a page number. @var{label} is the label set on the referenced
3347 page (using the @code{\\label} command), @var{gauge} a markup used to estimate
3348 the maximum width of the page number, and @var{default} the value to display
3349 when @var{label} is not found."
3350   (let* ((gauge-stencil (interpret-markup layout props gauge))
3351          (x-ext (ly:stencil-extent gauge-stencil X))
3352          (y-ext (ly:stencil-extent gauge-stencil Y)))
3353     (ly:make-stencil
3354      `(delay-stencil-evaluation
3355        ,(delay (ly:stencil-expr
3356                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
3357                        (page-number (if (list? table)
3358                                         (assoc-get label table)
3359                                         #f))
3360                        (page-markup (if page-number (format "~a" page-number) default))
3361                        (page-stencil (interpret-markup layout props page-markup))
3362                        (gap (- (interval-length x-ext)
3363                                (interval-length (ly:stencil-extent page-stencil X)))))
3364                   (interpret-markup layout props
3365                                     (markup #:concat (#:hspace gap page-markup)))))))
3366      x-ext
3367      y-ext)))
3368
3369 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3370 ;; scaling
3371 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3372
3373 (define-markup-command (scale layout props factor-pair arg)
3374   (number-pair? markup?)
3375   #:category graphic
3376   "
3377 @cindex scaling markup
3378 @cindex mirroring markup
3379
3380 Scale @var{arg}.  @var{factor-pair} is a pair of numbers
3381 representing the scaling-factor in the X and Y axes.
3382 Negative values may be used to produce mirror images.
3383
3384 @lilypond[verbatim,quote]
3385 \\markup {
3386   \\line {
3387     \\scale #'(2 . 1)
3388     stretched
3389     \\scale #'(1 . -1)
3390     mirrored
3391   }
3392 }
3393 @end lilypond"
3394   (let ((stil (interpret-markup layout props arg))
3395         (sx (car factor-pair))
3396         (sy (cdr factor-pair)))
3397     (ly:stencil-scale stil sx sy)))
3398
3399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3400 ;; Markup list commands
3401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3402
3403 (define-public (space-lines baseline stils)
3404   (let space-stil ((stils stils)
3405                    (result (list)))
3406     (if (null? stils)
3407         (reverse! result)
3408         (let* ((stil (car stils))
3409                (dy-top (max (- (/ baseline 1.5)
3410                                (interval-bound (ly:stencil-extent stil Y) UP))
3411                             0.0))
3412                (dy-bottom (max (+ (/ baseline 3.0)
3413                                   (interval-bound (ly:stencil-extent stil Y) DOWN))
3414                                0.0))
3415                (new-stil (ly:make-stencil
3416                           (ly:stencil-expr stil)
3417                           (ly:stencil-extent stil X)
3418                           (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN)
3419                                    dy-bottom)
3420                                 (+ (interval-bound (ly:stencil-extent stil Y) UP)
3421                                    dy-top)))))
3422           (space-stil (cdr stils) (cons new-stil result))))))
3423
3424 (define-markup-list-command (justified-lines layout props args)
3425   (markup-list?)
3426   #:properties ((baseline-skip)
3427                 wordwrap-internal-markup-list)
3428   "
3429 @cindex justifying lines of text
3430
3431 Like @code{\\justify}, but return a list of lines instead of a single markup.
3432 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
3433 @var{X}@tie{}is the number of staff spaces."
3434   (space-lines baseline-skip
3435                (interpret-markup-list layout props
3436                                       (make-wordwrap-internal-markup-list #t args))))
3437
3438 (define-markup-list-command (wordwrap-lines layout props args)
3439   (markup-list?)
3440   #:properties ((baseline-skip)
3441                 wordwrap-internal-markup-list)
3442   "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
3443 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
3444 where @var{X} is the number of staff spaces."
3445   (space-lines baseline-skip
3446                (interpret-markup-list layout props
3447                                       (make-wordwrap-internal-markup-list #f args))))
3448
3449 (define-markup-list-command (column-lines layout props args)
3450   (markup-list?)
3451   #:properties ((baseline-skip))
3452   "Like @code{\\column}, but return a list of lines instead of a single markup.
3453 @code{baseline-skip} determines the space between each markup in @var{args}."
3454   (space-lines baseline-skip
3455                (interpret-markup-list layout props args)))
3456
3457 (define-markup-list-command (override-lines layout props new-prop args)
3458   (pair? markup-list?)
3459   "Like @code{\\override}, for markup lists."
3460   (interpret-markup-list layout (cons (list new-prop) props) args))