scm/define-markup-commands.scm

   1 ;;;; define-markup-commands.scm -- markup commands
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2000--2007  Han-Wen Nienhuys <hanwen@xs4all.nl>
   6 ;;;;                  Jan Nieuwenhuizen <janneke@gnu.org>
   7
   8
   9 ;;; markup commands
  10 ;;;  * each markup function should have a doc string with
  11 ;;     syntax, description and example.
  12
  13 (use-modules (ice-9 regex))
  14
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;; utility functions
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18
  19 (define-public empty-stencil (ly:make-stencil '() '(1 . -1) '(1 . -1)))
  20 (define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; geometric shapes
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25
  26 (define-builtin-markup-command (draw-line layout props dest)
  27   (number-pair?)
  28   graphic
  29   ((thickness 1))
  30   "
  31 @cindex drawing lines within text
  32
  33 A simple line.
  34 @lilypond[verbatim,quote]
  35 \\markup {
  36   \\draw-line #'(4 . 4)
  37   \\override #'(thickness . 5)
  38   \\draw-line #'(-3 . 0)
  39 }
  40 @end lilypond"
  41   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
  42                thickness))
  43         (x (car dest))
  44         (y (cdr dest)))
  45     (ly:make-stencil
  46      `(draw-line
  47        ,th
  48        0 0
  49        ,x ,y)
  50      (cons (min x 0) (max x 0))
  51      (cons (min y 0) (max y 0)))))
  52
  53 (define-builtin-markup-command (draw-circle layout props radius thickness fill)
  54   (number? number? boolean?)
  55   graphic
  56   ()
  57   "
  58 @cindex drawing circles within text
  59
  60 A circle of radius @var{radius}, thickness @var{thickness} and
  61 optionally filled.
  62
  63 @lilypond[verbatim,quote]
  64 \\markup {
  65   \\draw-circle #2 #0.5 ##f
  66   \\hspace #2
  67   \\draw-circle #2 #0 ##t
  68 }
  69 @end lilypond"
  70   (make-circle-stencil radius thickness fill))
  71
  72 (define-builtin-markup-command (triangle layout props filled)
  73   (boolean?)
  74   graphic
  75   ((thickness 0.1)
  76    (font-size 0)
  77    (baseline-skip 2))
  78   "
  79 @cindex drawing triangles within text
  80
  81 A triangle, either filled or empty.
  82
  83 @lilypond[verbatim,quote]
  84 \\markup {
  85   \\triangle ##t
  86   \\hspace #2
  87   \\triangle ##f
  88 }
  89 @end lilypond"
  90   (let ((ex (* (magstep font-size) 0.8 baseline-skip)))
  91     (ly:make-stencil
  92      `(polygon '(0.0 0.0
  93                      ,ex 0.0
  94                      ,(* 0.5 ex)
  95                      ,(* 0.86 ex))
  96            ,thickness
  97            ,filled)
  98      (cons 0 ex)
  99      (cons 0 (* .86 ex)))))
 100
 101 (define-builtin-markup-command (circle layout props arg)
 102   (markup?)
 103   graphic
 104   ((thickness 1)
 105    (font-size 0)
 106    (circle-padding 0.2))
 107   "
 108 @cindex circling text
 109
 110 Draw a circle around @var{arg}.  Use @code{thickness},
 111 @code{circle-padding} and @code{font-size} properties to determine line
 112 thickness and padding around the markup.
 113
 114 @lilypond[verbatim,quote]
 115 \\markup {
 116   \\circle {
 117     Hi
 118   }
 119 }
 120 @end lilypond"
 121   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 122                thickness))
 123          (pad (* (magstep font-size) circle-padding))
 124          (m (interpret-markup layout props arg)))
 125     (circle-stencil m th pad)))
 126
 127 (define-builtin-markup-command (with-url layout props url arg)
 128   (string? markup?)
 129   graphic
 130   ()
 131   "
 132 @cindex inserting URL links into text
 133
 134 Add a link to URL @var{url} around @var{arg}.  This only works in
 135 the PDF backend.
 136
 137 @lilypond[verbatim,quote]
 138 \\markup {
 139   \\with-url #\"http://lilypond.org/web/\" {
 140     LilyPond ... \\italic {
 141       music notation for everyone
 142     }
 143   }
 144 }
 145 @end lilypond"
 146   (let* ((stil (interpret-markup layout props arg))
 147          (xextent (ly:stencil-extent stil X))
 148          (yextent (ly:stencil-extent stil Y))
 149          (old-expr (ly:stencil-expr stil))
 150          (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
 151
 152     (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
 153
 154 (define-builtin-markup-command (beam layout props width slope thickness)
 155   (number? number? number?)
 156   graphic
 157   ()
 158   "
 159 @cindex drawing beams within text
 160
 161 Create a beam with the specified parameters.
 162 @lilypond[verbatim,quote]
 163 \\markup {
 164   \\beam #5 #1 #2
 165 }
 166 @end lilypond"
 167   (let* ((y (* slope width))
 168          (yext (cons (min 0 y) (max 0 y)))
 169          (half (/ thickness 2)))
 170
 171     (ly:make-stencil
 172      `(polygon ',(list
 173                   0 (/ thickness -2)
 174                     width (+ (* width slope)  (/ thickness -2))
 175                     width (+ (* width slope)  (/ thickness 2))
 176                     0 (/ thickness 2))
 177                ,(ly:output-def-lookup layout 'blot-diameter)
 178                #t)
 179      (cons 0 width)
 180      (cons (+ (- half) (car yext))
 181            (+ half (cdr yext))))))
 182
 183 (define-builtin-markup-command (underline layout props arg)
 184   (markup?)
 185   font
 186   ((thickness 1))
 187   "
 188 @cindex underlining text
 189
 190 Underline @var{arg}.  Looks at @code{thickness} to determine line
 191 thickness and y offset.
 192
 193 @lilypond[verbatim,quote]
 194 \\markup {
 195   \\override #'(thickness . 2)
 196   \\underline {
 197     CONTENTS
 198   }
 199 }
 200 @end lilypond"
 201   (let* ((thick (* (ly:output-def-lookup layout 'line-thickness)
 202                    thickness))
 203          (markup (interpret-markup layout props arg))
 204          (x1 (car (ly:stencil-extent markup X)))
 205          (x2 (cdr (ly:stencil-extent markup X)))
 206          (y (* thick -2))
 207          (line (ly:make-stencil
 208                 `(draw-line ,thick ,x1 ,y ,x2 ,y)
 209                 (cons (min x1 0) (max x2 0))
 210                 (cons thick thick))))
 211     (ly:stencil-add markup line)))
 212
 213 (define-builtin-markup-command (box layout props arg)
 214   (markup?)
 215   font
 216   ((thickness 1)
 217    (font-size 0)
 218    (box-padding 0.2))
 219   "
 220 @cindex enclosing text within a box
 221
 222 Draw a box round @var{arg}.  Looks at @code{thickness},
 223 @code{box-padding} and @code{font-size} properties to determine line
 224 thickness and padding around the markup.
 225
 226 @lilypond[verbatim,quote]
 227 \\markup {
 228   \\override #'(box-padding . 0.5)
 229   \\box
 230   \\line { V. S. }
 231 }
 232 @end lilypond"
 233   (let* ((th (* (ly:output-def-lookup layout 'line-thickness)
 234                 thickness))
 235          (pad (* (magstep font-size) box-padding))
 236          (m (interpret-markup layout props arg)))
 237     (box-stencil m th pad)))
 238
 239 (define-builtin-markup-command (filled-box layout props xext yext blot)
 240   (number-pair? number-pair? number?)
 241   graphic
 242   ()
 243   "
 244 @cindex drawing solid boxes within text
 245 @cindex drawing boxes with rounded corners
 246
 247 Draw a box with rounded corners of dimensions @var{xext} and
 248 @var{yext}.  For example,
 249 @verbatim
 250 \\filled-box #'(-.3 . 1.8) #'(-.3 . 1.8) #0
 251 @end verbatim
 252 creates a box extending horizontally from -0.3 to 1.8 and
 253 vertically from -0.3 up to 1.8, with corners formed from a
 254 circle of diameter@tie{}0 (i.e. sharp corners).
 255
 256 @lilypond[verbatim,quote]
 257 \\markup {
 258   \\filled-box #'(0 . 4) #'(0 . 4) #0
 259   \\filled-box #'(0 . 2) #'(-4 . 2) #0.4
 260   \\filled-box #'(1 . 8) #'(0 . 7) #0.2
 261   \\with-color #white
 262   \\filled-box #'(-4.5 . -2.5) #'(3.5 . 5.5) #0.7
 263 }
 264 @end lilypond"
 265   (ly:round-filled-box
 266    xext yext blot))
 267
 268 (define-builtin-markup-command (rounded-box layout props arg)
 269   (markup?)
 270   graphic
 271   ((thickness 1)
 272    (corner-radius 1)
 273    (font-size 0)
 274    (box-padding 0.5))
 275   "@cindex enclosing text in a bow with rounded corners
 276    @cindex drawing boxes with rounded corners around text
 277 Draw a box with rounded corners around @var{arg}.  Looks at @code{thickness},
 278 @code{box-padding} and @code{font-size} properties to determine line
 279 thickness and padding around the markup; the @code{corner-radius} property
 280 makes possible to define another shape for the corners (default is 1).
 281
 282 @lilypond[quote,verbatim,fragment,relative=2]
 283 c4^\\markup {
 284   \\rounded-box {
 285     Overtura
 286   }
 287 }
 288 c,8. c16 c4 r
 289 @end lilypond"
 290   (let ((th (* (ly:output-def-lookup layout 'line-thickness)
 291                thickness))
 292         (pad (* (magstep font-size) box-padding))
 293         (m (interpret-markup layout props arg)))
 294     (ly:stencil-add (rounded-box-stencil m th pad corner-radius)
 295                     m)))
 296
 297 (define-builtin-markup-command (rotate layout props ang arg)
 298   (number? markup?)
 299   align
 300   ()
 301   "
 302 @cindex rotating text
 303
 304 Rotate object with @var{ang} degrees around its center."
 305   (let* ((stil (interpret-markup layout props arg)))
 306     (ly:stencil-rotate stil ang 0 0)))
 307
 308 (define-builtin-markup-command (whiteout layout props arg)
 309   (markup?)
 310   other
 311   ()
 312   "
 313 @cindex adding a white background to text
 314
 315 Provide a white background for @var{arg}."
 316   (stencil-whiteout (interpret-markup layout props arg)))
 317
 318 (define-builtin-markup-command (pad-markup layout props padding arg)
 319   (number? markup?)
 320   align
 321   ()
 322   "
 323 @cindex padding text
 324 @cindex putting space around text
 325
 326 Add space around a markup object."
 327   (let*
 328       ((stil (interpret-markup layout props arg))
 329        (xext (ly:stencil-extent stil X))
 330        (yext (ly:stencil-extent stil Y)))
 331
 332     (ly:make-stencil
 333      (ly:stencil-expr stil)
 334      (interval-widen xext padding)
 335      (interval-widen yext padding))))
 336
 337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 338 ;; space
 339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 340
 341 (define-builtin-markup-command (strut layout props)
 342   ()
 343   other
 344   ()
 345   "
 346 @cindex creating vertical spaces in text
 347
 348 Create a box of the same height as the space in the current font."
 349   (let ((m (ly:text-interface::interpret-markup layout props " ")))
 350     (ly:make-stencil (ly:stencil-expr m)
 351                      '(0 . 0)
 352                      (ly:stencil-extent m X)
 353                      )))
 354
 355 ;; todo: fix negative space
 356 (define-builtin-markup-command (hspace layout props amount)
 357   (number?)
 358   align
 359   ()
 360   "
 361 @cindex creating horizontal spaces in text
 362
 363 This produces an invisible object taking horizontal space.  For example,
 364
 365 @example
 366 \\markup @{ A \\hspace #2.0 B @}
 367 @end example
 368
 369 @noindent
 370 puts extra space between A and@tie{}B, on top of the space that is
 371 normally inserted before elements on a line.
 372
 373 @lilypond[verbatim,quote]
 374 \\markup {
 375   one
 376   \\hspace #2
 377   two
 378   \\hspace #8
 379   three
 380 }
 381 @end lilypond"
 382   (if (> amount 0)
 383       (ly:make-stencil "" (cons 0 amount) '(-1 . 1))
 384       (ly:make-stencil "" (cons amount amount) '(-1 . 1))))
 385
 386
 387 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 388 ;; importing graphics.
 389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 390
 391 (define-builtin-markup-command (stencil layout props stil)
 392   (ly:stencil?)
 393   other
 394   ()
 395   "
 396 @cindex importing stencils into text
 397
 398 Use a stencil as markup."
 399   stil)
 400
 401 (define bbox-regexp
 402   (make-regexp "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))
 403
 404 (define (get-postscript-bbox string)
 405   "Extract the bbox from STRING, or return #f if not present."
 406   (let*
 407       ((match (regexp-exec bbox-regexp string)))
 408
 409     (if match
 410         (map (lambda (x)
 411                (string->number (match:substring match x)))
 412              (cdr (iota 5)))
 413
 414         #f)))
 415
 416 (define-builtin-markup-command (epsfile layout props axis size file-name)
 417   (number? number? string?)
 418   graphic
 419   ()
 420   "
 421 @cindex inlining an Encapsulated PostScript image
 422
 423 Inline an EPS image.  The image is scaled along @var{axis} to
 424 @var{size}.
 425
 426 @lilypond[verbatim,quote]
 427 \\markup {
 428   \\general-align #Y #DOWN {
 429     \\epsfile #X #20 #\"context-example.eps\"
 430     \\epsfile #Y #20 #\"context-example.eps\"
 431   }
 432 }
 433 @end lilypond"
 434   (if (ly:get-option 'safe)
 435       (interpret-markup layout props "not allowed in safe")
 436       (eps-file->stencil axis size file-name)
 437       ))
 438
 439 (define-builtin-markup-command (postscript layout props str)
 440   (string?)
 441   graphic
 442   ()
 443   "
 444 @cindex inserting PostScript directly into text
 445
 446 This inserts @var{str} directly into the output as a PostScript
 447 command string.  Due to technicalities of the output backends,
 448 different scales should be used for the @TeX{} and PostScript backend,
 449 selected with @code{-f}.
 450
 451 For the @TeX{} backend, the following string prints a rotated text
 452
 453 @example
 454 0 0 moveto /ecrm10 findfont
 455 1.75 scalefont setfont 90 rotate (hello) show
 456 @end example
 457
 458 @noindent
 459 The magical constant 1.75 scales from LilyPond units (staff spaces) to
 460 @TeX{} dimensions.
 461
 462 For the postscript backend, use the following
 463
 464 @example
 465 gsave /ecrm10 findfont
 466  10.0 output-scale div
 467  scalefont setfont 90 rotate (hello) show grestore
 468 @end example
 469
 470 @lilypond[verbatim,quote]
 471 eyeglassesps = #\"
 472   0.15 setlinewidth
 473   -0.9 0 translate
 474   1.1 1.1 scale
 475   1.2 0.7 moveto
 476   0.7 0.7 0.5 0 361 arc
 477   stroke
 478   2.20 0.70 0.50 0 361 arc
 479   stroke
 480   1.45 0.85 0.30 0 180 arc
 481   stroke
 482   0.20 0.70 moveto
 483   0.80 2.00 lineto
 484   0.92 2.26 1.30 2.40 1.15 1.70 curveto
 485   stroke
 486   2.70 0.70 moveto
 487   3.30 2.00 lineto
 488   3.42 2.26 3.80 2.40 3.65 1.70 curveto
 489   stroke\"
 490
 491 eyeglasses = \\markup {
 492   \\with-dimensions #'(0 . 4.4) #'(0 . 2.5)
 493   \\postscript #eyeglassesps
 494 }
 495
 496 \\relative c'' {
 497   c2^\\eyeglasses
 498   a2_\\eyeglasses
 499 }
 500 @end lilypond"
 501   ;; FIXME
 502   (ly:make-stencil
 503    (list 'embedded-ps
 504          (format "
 505 gsave currentpoint translate
 506 0.1 setlinewidth
 507  ~a
 508 grestore
 509 "
 510                  str))
 511    '(0 . 0) '(0 . 0)))
 512
 513 (define-builtin-markup-command (score layout props score)
 514   (ly:score?)
 515   music
 516   ()
 517   "
 518 @cindex inserting music into text
 519
 520 Inline an image of music.
 521
 522 @lilypond[verbatim,quote]
 523 \\markup {
 524   \\score {
 525     \\new PianoStaff <<
 526       \\new Staff \\relative c' {
 527         \\key f \\major
 528         \\time 3/4
 529         \\mark \\markup { Allegro }
 530         f2\\p( a4)
 531         c2( a4)
 532         bes2( g'4)
 533         f8( e) e4 r
 534       }
 535       \\new Staff \\relative c {
 536         \\clef bass
 537         \\key f \\major
 538         \\time 3/4
 539         f8( a c a c a
 540         f c' es c es c)
 541         f,( bes d bes d bes)
 542         f( g bes g bes g)
 543       }
 544     >>
 545     \\layout {
 546       indent = 0.0\\cm
 547       \\context {
 548         \\Score
 549         \\override RehearsalMark #'break-align-symbols =
 550           #'(time-signature key-signature)
 551         \\override RehearsalMark #'self-alignment-X = #LEFT
 552       }
 553       \\context {
 554         \\Staff
 555         \\override TimeSignature #'break-align-anchor-alignment = #LEFT
 556       }
 557     }
 558   }
 559 }
 560 @end lilypond"
 561   (let* ((output (ly:score-embedded-format score layout)))
 562
 563     (if (ly:music-output? output)
 564         (paper-system-stencil
 565          (vector-ref (ly:paper-score-paper-systems output) 0))
 566         (begin
 567           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
 568           empty-stencil))))
 569
 570 (define-builtin-markup-command (null layout props)
 571   ()
 572   other
 573   ()
 574   "
 575 @cindex creating empty text objects
 576
 577 An empty markup with extents of a single point.
 578
 579 @lilypond[verbatim,quote]
 580 \\markup {
 581   \\null
 582 }
 583 @end lilypond"
 584   point-stencil)
 585
 586 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 587 ;; basic formatting.
 588 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 589
 590 (define-builtin-markup-command (simple layout props str)
 591   (string?)
 592   font
 593   ()
 594   "
 595 @cindex simple text strings
 596
 597 A simple text string; @code{\\markup @{ foo @}} is equivalent with
 598 @code{\\markup @{ \\simple #\"foo\" @}}.
 599
 600 @lilypond[verbatim,quote]
 601 \\markup {
 602   \\simple #\"simple\"
 603   \\simple #\"text\"
 604   \\simple #\"strings\"
 605 }
 606 @end lilypond"
 607   (interpret-markup layout props str))
 608
 609 (define-builtin-markup-command (tied-lyric layout props str)
 610   (string?)
 611   music
 612   ()
 613   "
 614 @cindex simple text strings with tie characters
 615
 616 Like simple-markup, but use tie characters for @q{~} tilde symbols.
 617
 618 @lilypond[verbatim,quote]
 619 \\markup {
 620   \\tied-lyric #\"Lasciate~i monti\"
 621 }
 622 @end lilypond"
 623   (if (string-contains str "~")
 624       (let*
 625           ((parts (string-split str #\~))
 626            (tie-str (ly:wide-char->utf-8 #x203f))
 627            (joined  (list-join parts tie-str))
 628            (join-stencil (interpret-markup layout props tie-str))
 629            )
 630
 631         (interpret-markup layout
 632                           (prepend-alist-chain
 633                            'word-space
 634                            (/ (interval-length (ly:stencil-extent join-stencil X)) -3.5)
 635                            props)
 636                           (make-line-markup joined)))
 637                            ;(map (lambda (s) (interpret-markup layout props s)) parts))
 638       (interpret-markup layout props str)))
 639
 640 (define-public empty-markup
 641   (make-simple-markup ""))
 642
 643 ;; helper for justifying lines.
 644 (define (get-fill-space word-count line-width text-widths)
 645   "Calculate the necessary paddings between each two adjacent texts.
 646         The lengths of all texts are stored in @var{text-widths}.
 647         The normal formula for the padding between texts a and b is:
 648         padding = line-width/(word-count - 1) - (length(a) + length(b))/2
 649         The first and last padding have to be calculated specially using the
 650         whole length of the first or last text.
 651         Return a list of paddings."
 652   (cond
 653    ((null? text-widths) '())
 654
 655    ;; special case first padding
 656    ((= (length text-widths) word-count)
 657     (cons
 658      (- (- (/ line-width (1- word-count)) (car text-widths))
 659         (/ (car (cdr text-widths)) 2))
 660      (get-fill-space word-count line-width (cdr text-widths))))
 661    ;; special case last padding
 662    ((= (length text-widths) 2)
 663     (list (- (/ line-width (1- word-count))
 664              (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
 665    (else
 666     (cons
 667      (- (/ line-width (1- word-count))
 668         (/ (+ (car text-widths) (car (cdr text-widths))) 2))
 669      (get-fill-space word-count line-width (cdr text-widths))))))
 670
 671 (define-builtin-markup-command (fill-line layout props markups)
 672   (markup-list?)
 673   align
 674   ((text-direction RIGHT)
 675    (word-space 1)
 676    (line-width #f))
 677   "Put @var{markups} in a horizontal line of width @var{line-width}.
 678 The markups are spaced or flushed to fill the entire line.
 679 If there are no arguments, return an empty stencil.
 680
 681 @lilypond[verbatim,quote]
 682 \\markup {
 683   \\column {
 684     \\fill-line {
 685       Words evenly spaced across the page
 686     }
 687     \\null
 688     \\fill-line {
 689       \\line { Text markups }
 690       \\line {
 691         \\italic { evenly spaced }
 692       }
 693       \\line { across the page }
 694     }
 695   }
 696 }
 697 @end lilypond"
 698   (let* ((orig-stencils (interpret-markup-list layout props markups))
 699          (stencils
 700           (map (lambda (stc)
 701                  (if (ly:stencil-empty? stc)
 702                      point-stencil
 703                      stc)) orig-stencils))
 704          (text-widths
 705           (map (lambda (stc)
 706                  (if (ly:stencil-empty? stc)
 707                      0.0
 708                      (interval-length (ly:stencil-extent stc X))))
 709                stencils))
 710          (text-width (apply + text-widths))
 711          (word-count (length stencils))
 712          (prop-line-width (chain-assoc-get 'line-width props #f))
 713          (line-width (or line-width (ly:output-def-lookup layout 'line-width)))
 714          (fill-space
 715                 (cond
 716                         ((= word-count 1)
 717                                 (list
 718                                         (/ (- line-width text-width) 2)
 719                                         (/ (- line-width text-width) 2)))
 720                         ((= word-count 2)
 721                                 (list
 722                                         (- line-width text-width)))
 723                         (else
 724                                 (get-fill-space word-count line-width text-widths))))
 725          (fill-space-normal
 726           (map (lambda (x)
 727                  (if (< x word-space)
 728                      word-space
 729                      x))
 730                fill-space))
 731
 732          (line-stencils (if (= word-count 1)
 733                             (list
 734                              point-stencil
 735                              (car stencils)
 736                              point-stencil)
 737                             stencils)))
 738
 739     (if (= text-direction LEFT)
 740         (set! line-stencils (reverse line-stencils)))
 741
 742     (if (null? (remove ly:stencil-empty? orig-stencils))
 743         empty-stencil
 744         (stack-stencils-padding-list X
 745                                      RIGHT fill-space-normal line-stencils))))
 746
 747 (define-builtin-markup-command (line layout props args)
 748   (markup-list?)
 749   align
 750   ((word-space)
 751    (text-direction RIGHT))
 752   "Put @var{args} in a horizontal line.  The property @code{word-space}
 753 determines the space between each markup in @var{args}.
 754
 755 @lilypond[verbatim,quote]
 756 \\markup {
 757   \\line {
 758     A simple line of text
 759   }
 760 }
 761 @end lilypond"
 762   (let ((stencils (interpret-markup-list layout props args)))
 763     (if (= text-direction LEFT)
 764         (set! stencils (reverse stencils)))
 765     (stack-stencil-line
 766      word-space
 767      (remove ly:stencil-empty? stencils))))
 768
 769 (define-builtin-markup-command (concat layout props args)
 770   (markup-list?)
 771   align
 772   ()
 773   "
 774 @cindex concatenating text
 775 @cindex ligatures in text
 776
 777 Concatenate @var{args} in a horizontal line, without spaces inbetween.
 778 Strings and simple markups are concatenated on the input level, allowing
 779 ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
 780 equivalent to @code{\"fi\"}.
 781
 782 @lilypond[verbatim,quote]
 783 \\markup {
 784   \\bold {
 785     au
 786     \\concat {
 787       Mouv
 788       \\super
 789       t
 790     }
 791   }
 792 }
 793 @end lilypond"
 794   (define (concat-string-args arg-list)
 795     (fold-right (lambda (arg result-list)
 796                   (let ((result (if (pair? result-list)
 797                                     (car result-list)
 798                                   '())))
 799                     (if (and (pair? arg) (eqv? (car arg) simple-markup))
 800                       (set! arg (cadr arg)))
 801                     (if (and (string? result) (string? arg))
 802                         (cons (string-append arg result) (cdr result-list))
 803                       (cons arg result-list))))
 804                 '()
 805                 arg-list))
 806
 807   (interpret-markup layout
 808                     (prepend-alist-chain 'word-space 0 props)
 809                     (make-line-markup (if (markup-command-list? args)
 810                                           args
 811                                           (concat-string-args args)))))
 812
 813 (define (wordwrap-stencils stencils
 814                            justify base-space line-width text-dir)
 815   "Perform simple wordwrap, return stencil of each line."
 816   (define space (if justify
 817                     ;; justify only stretches lines.
 818                     (* 0.7 base-space)
 819                     base-space))
 820   (define (take-list width space stencils
 821                      accumulator accumulated-width)
 822     "Return (head-list . tail) pair, with head-list fitting into width"
 823     (if (null? stencils)
 824         (cons accumulator stencils)
 825         (let* ((first (car stencils))
 826                (first-wid (cdr (ly:stencil-extent (car stencils) X)))
 827                (newwid (+ space first-wid accumulated-width)))
 828           (if (or (null? accumulator)
 829                   (< newwid width))
 830               (take-list width space
 831                          (cdr stencils)
 832                          (cons first accumulator)
 833                          newwid)
 834               (cons accumulator stencils)))))
 835   (let loop ((lines '())
 836              (todo stencils))
 837     (let* ((line-break (take-list line-width space todo
 838                                   '() 0.0))
 839            (line-stencils (car line-break))
 840            (space-left (- line-width
 841                           (apply + (map (lambda (x) (cdr (ly:stencil-extent x X)))
 842                                         line-stencils))))
 843            (line-word-space (cond ((not justify) space)
 844                                   ;; don't stretch last line of paragraph.
 845                                   ;; hmmm . bug - will overstretch the last line in some case.
 846                                   ((null? (cdr line-break))
 847                                    base-space)
 848                                   ((null? line-stencils) 0.0)
 849                                   ((null? (cdr line-stencils)) 0.0)
 850                                   (else (/ space-left (1- (length line-stencils))))))
 851            (line (stack-stencil-line line-word-space
 852                                      (if (= text-dir RIGHT)
 853                                          (reverse line-stencils)
 854                                          line-stencils))))
 855       (if (pair? (cdr line-break))
 856           (loop (cons line lines)
 857                 (cdr line-break))
 858           (begin
 859             (if (= text-dir LEFT)
 860                 (set! line
 861                       (ly:stencil-translate-axis
 862                        line
 863                        (- line-width (interval-end (ly:stencil-extent line X)))
 864                        X)))
 865             (reverse (cons line lines)))))))
 866
 867 (define-builtin-markup-list-command (wordwrap-internal layout props justify args)
 868   (boolean? markup-list?)
 869   ((line-width #f)
 870    (word-space)
 871    (text-direction RIGHT))
 872   "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}."
 873   (wordwrap-stencils (remove ly:stencil-empty?
 874                              (interpret-markup-list layout props args))
 875                      justify
 876                      word-space
 877                      (or line-width
 878                          (ly:output-def-lookup layout 'line-width))
 879                      text-direction))
 880
 881 (define-builtin-markup-command (justify layout props args)
 882   (markup-list?)
 883   align
 884   ((baseline-skip)
 885    wordwrap-internal-markup-list)
 886   "
 887 @cindex justifying text
 888
 889 Like wordwrap, but with lines stretched to justify the margins.
 890 Use @code{\\override #'(line-width . @var{X})} to set the line width;
 891 @var{X}@tie{}is the number of staff spaces."
 892   (stack-lines DOWN 0.0 baseline-skip
 893                (wordwrap-internal-markup-list layout props #t args)))
 894
 895 (define-builtin-markup-command (wordwrap layout props args)
 896   (markup-list?)
 897   align
 898   ((baseline-skip)
 899    wordwrap-internal-markup-list)
 900   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
 901 the line width, where @var{X} is the number of staff spaces."
 902   (stack-lines DOWN 0.0 baseline-skip
 903                (wordwrap-internal-markup-list layout props #f args)))
 904
 905 (define-builtin-markup-list-command (wordwrap-string-internal layout props justify arg)
 906   (boolean? string?)
 907   ((line-width)
 908    (word-space)
 909    (text-direction RIGHT))
 910   "Internal markup list command used to define @code{\\justify-string} and
 911 @code{\\wordwrap-string}."
 912   (let* ((para-strings (regexp-split
 913                         (string-regexp-substitute
 914                          "\r" "\n"
 915                          (string-regexp-substitute "\r\n" "\n" arg))
 916                         "\n[ \t\n]*\n[ \t\n]*"))
 917          (list-para-words (map (lambda (str)
 918                                  (regexp-split str "[ \t\n]+"))
 919                                para-strings))
 920          (para-lines (map (lambda (words)
 921                             (let* ((stencils
 922                                     (remove ly:stencil-empty?
 923                                             (map (lambda (x)
 924                                                    (interpret-markup layout props x))
 925                                                  words))))
 926                               (wordwrap-stencils stencils
 927                                                  justify word-space
 928                                                  line-width text-direction)))
 929                           list-para-words)))
 930     (apply append para-lines)))
 931
 932 (define-builtin-markup-command (wordwrap-string layout props arg)
 933   (string?)
 934   align
 935   ((baseline-skip)
 936    wordwrap-string-internal-markup-list)
 937   "Wordwrap a string.  Paragraphs may be separated with double newlines."
 938   (stack-lines DOWN 0.0 baseline-skip
 939                (wordwrap-string-internal-markup-list layout props #f arg)))
 940
 941 (define-builtin-markup-command (justify-string layout props arg)
 942   (string?)
 943   align
 944   ((baseline-skip)
 945    wordwrap-string-internal-markup-list)
 946   "Justify a string.  Paragraphs may be separated with double newlines"
 947   (stack-lines DOWN 0.0 baseline-skip
 948                (wordwrap-string-internal-markup-list layout props #t arg)))
 949
 950 (define-builtin-markup-command (wordwrap-field layout props symbol)
 951   (symbol?)
 952   align
 953   ()
 954   "Wordwrap the data which has been assigned to @var{symbol}."
 955   (let* ((m (chain-assoc-get symbol props)))
 956     (if (string? m)
 957         (wordwrap-string-markup layout props m)
 958         empty-stencil)))
 959
 960 (define-builtin-markup-command (justify-field layout props symbol)
 961   (symbol?)
 962   align
 963   ()
 964   "Justify the data which has been assigned to @var{symbol}."
 965   (let* ((m (chain-assoc-get symbol props)))
 966     (if (string? m)
 967         (justify-string-markup layout props m)
 968         empty-stencil)))
 969
 970 (define-builtin-markup-command (combine layout props m1 m2)
 971   (markup? markup?)
 972   align
 973   ()
 974   "
 975 @cindex merging text
 976
 977 Print two markups on top of each other.
 978 @lilypond[verbatim,quote]
 979 \\markup {
 980   \\fontsize #5
 981   \\override #'(thickness . 2)
 982   \\combine
 983   \\draw-line #'(0 . 4)
 984   \\arrow-head #Y #DOWN ##f
 985 }
 986 @end lilypond"
 987   (let* ((s1 (interpret-markup layout props m1))
 988          (s2 (interpret-markup layout props m2)))
 989     (ly:stencil-add s1 s2)))
 990
 991 ;;
 992 ;; TODO: should extract baseline-skip from each argument somehow..
 993 ;;
 994 (define-builtin-markup-command (column layout props args)
 995   (markup-list?)
 996   align
 997   ((baseline-skip))
 998   "
 999 @cindex stacking text in a column
1000
1001 Stack the markups in @var{args} vertically.  The property
1002 @code{baseline-skip} determines the space between each
1003 markup in @var{args}.
1004
1005 @lilypond[verbatim,quote]
1006 \\markup {
1007   \\column {
1008     one
1009     two
1010     three
1011   }
1012 }
1013 @end lilypond"
1014   (let ((arg-stencils (interpret-markup-list layout props args)))
1015     (stack-lines -1 0.0 baseline-skip
1016                  (remove ly:stencil-empty? arg-stencils))))
1017
1018 (define-builtin-markup-command (dir-column layout props args)
1019   (markup-list?)
1020   align
1021   ((direction)
1022    (baseline-skip))
1023   "
1024 @cindex changing direction of text columns
1025
1026 Make a column of args, going up or down, depending on the setting
1027 of the @code{#'direction} layout property.
1028
1029 @lilypond[verbatim,quote]
1030 \\markup {
1031   \\override #'(direction . 1) {
1032     \\dir-column {
1033       going up
1034     }
1035   }
1036   \\dir-column {
1037     going down
1038   }
1039 }
1040 @end lilypond"
1041   (stack-lines (if (number? direction) direction -1)
1042                0.0
1043                baseline-skip
1044                (interpret-markup-list layout props args)))
1045
1046 (define-builtin-markup-command (center-align layout props args)
1047   (markup-list?)
1048   align
1049   ((baseline-skip))
1050   "
1051 @cindex centering a column of text
1052
1053 Put @code{args} in a centered column.
1054
1055 @lilypond[verbatim,quote]
1056 \\markup {
1057   \\center-align {
1058     one
1059     two
1060     three
1061   }
1062 }
1063 @end lilypond"
1064   (let* ((mols (interpret-markup-list layout props args))
1065          (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
1066     (stack-lines -1 0.0 baseline-skip cmols)))
1067
1068 (define-builtin-markup-command (vcenter layout props arg)
1069   (markup?)
1070   align
1071   ()
1072   "
1073 @cindex vertically centering text
1074
1075 Align @code{arg} to its Y@tie{}center.
1076
1077 @lilypond[verbatim,quote]
1078 \\markup {
1079   \\arrow-head #X #RIGHT ##f
1080   \\vcenter
1081   Centered
1082   \\arrow-head #X #LEFT ##f
1083 }
1084 @end lilypond"
1085   (let* ((mol (interpret-markup layout props arg)))
1086     (ly:stencil-aligned-to mol Y CENTER)))
1087
1088 (define-builtin-markup-command (hcenter layout props arg)
1089   (markup?)
1090   align
1091   ()
1092   "
1093 @cindex horizontally centering text
1094
1095 Align @code{arg} to its X@tie{}center.
1096
1097 @lilypond[verbatim,quote]
1098 \\markup {
1099   \\column {
1100     ↓
1101     \\hcenter
1102     centered
1103   }
1104 }
1105 @end lilypond"
1106   (let* ((mol (interpret-markup layout props arg)))
1107     (ly:stencil-aligned-to mol X CENTER)))
1108
1109 (define-builtin-markup-command (right-align layout props arg)
1110   (markup?)
1111   align
1112   ()
1113   "
1114 @cindex right aligning text
1115
1116 Align @var{arg} on its right edge.
1117
1118 @lilypond[verbatim,quote]
1119 \\markup {
1120   \\column {
1121     ↓
1122     \\right-align
1123     right-aligned
1124   }
1125 }
1126 @end lilypond"
1127   (let* ((m (interpret-markup layout props arg)))
1128     (ly:stencil-aligned-to m X RIGHT)))
1129
1130 (define-builtin-markup-command (left-align layout props arg)
1131   (markup?)
1132   align
1133   ()
1134   "
1135 @cindex left aligning text
1136
1137 Align @var{arg} on its left edge.
1138
1139 @lilypond[verbatim,quote]
1140 \\markup {
1141   \\column {
1142     ↓
1143     \\left-align
1144     left-aligned
1145   }
1146 }
1147 @end lilypond"
1148   (let* ((m (interpret-markup layout props arg)))
1149     (ly:stencil-aligned-to m X LEFT)))
1150
1151 (define-builtin-markup-command (general-align layout props axis dir arg)
1152   (integer? number? markup?)
1153   align
1154   ()
1155   "
1156 @cindex controlling general text alignment
1157
1158 Align @var{arg} in @var{axis} direction to the @var{dir} side."
1159   (let* ((m (interpret-markup layout props arg)))
1160     (ly:stencil-aligned-to m axis dir)))
1161
1162 (define-builtin-markup-command (halign layout props dir arg)
1163   (number? markup?)
1164   align
1165   ()
1166   "
1167 @cindex setting horizontal text alignment
1168
1169 Set horizontal alignment.  If @var{dir} is @code{-1}, then it is
1170 left-aligned, while @code{+1} is right.  Values in between interpolate
1171 alignment accordingly.
1172
1173 @lilypond[verbatim,quote]
1174 \\markup {
1175   \\column {
1176     ↓
1177     \\halign #LEFT
1178     Left
1179     ↓
1180     \\halign #CENTER
1181     Center
1182     ↓
1183     \\halign #RIGHT
1184     Right
1185     ↓
1186     \\halign #1.2
1187     \\line {
1188       Arbitrary alignment
1189     }
1190   }
1191 }
1192 @end lilypond"
1193   (let* ((m (interpret-markup layout props arg)))
1194     (ly:stencil-aligned-to m X dir)))
1195
1196 (define-builtin-markup-command (with-dimensions layout props x y arg)
1197   (number-pair? number-pair? markup?)
1198   other
1199   ()
1200   "
1201 @cindex setting extent of text objects
1202
1203 Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}."
1204   (let* ((m (interpret-markup layout props arg)))
1205     (ly:make-stencil (ly:stencil-expr m) x y)))
1206
1207 (define-builtin-markup-command (pad-around layout props amount arg)
1208   (number? markup?)
1209   align
1210   ()
1211   "Add padding @var{amount} all around @var{arg}."
1212   (let* ((m (interpret-markup layout props arg))
1213          (x (ly:stencil-extent m X))
1214          (y (ly:stencil-extent m Y)))
1215     (ly:make-stencil (ly:stencil-expr m)
1216                      (interval-widen x amount)
1217                      (interval-widen y amount))))
1218
1219 (define-builtin-markup-command (pad-x layout props amount arg)
1220   (number? markup?)
1221   align
1222   ()
1223   "
1224 @cindex padding text horizontally
1225
1226 Add padding @var{amount} around @var{arg} in the X@tie{}direction."
1227   (let* ((m (interpret-markup layout props arg))
1228          (x (ly:stencil-extent m X))
1229          (y (ly:stencil-extent m Y)))
1230     (ly:make-stencil (ly:stencil-expr m)
1231                      (interval-widen x amount)
1232                      y)))
1233
1234 (define-builtin-markup-command (put-adjacent layout props arg1 axis dir arg2)
1235   (markup? integer? ly:dir? markup?)
1236   align
1237   ()
1238   "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}."
1239   (let ((m1 (interpret-markup layout props arg1))
1240         (m2 (interpret-markup layout props arg2)))
1241     (ly:stencil-combine-at-edge m1 axis dir m2 0.0)))
1242
1243 (define-builtin-markup-command (transparent layout props arg)
1244   (markup?)
1245   other
1246   ()
1247   "Make the argument transparent."
1248   (let* ((m (interpret-markup layout props arg))
1249          (x (ly:stencil-extent m X))
1250          (y (ly:stencil-extent m Y)))
1251     (ly:make-stencil "" x y)))
1252
1253 (define-builtin-markup-command (pad-to-box layout props x-ext y-ext arg)
1254   (number-pair? number-pair? markup?)
1255   align
1256   ()
1257   "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space."
1258   (let* ((m (interpret-markup layout props arg))
1259          (x (ly:stencil-extent m X))
1260          (y (ly:stencil-extent m Y)))
1261     (ly:make-stencil (ly:stencil-expr m)
1262                      (interval-union x-ext x)
1263                      (interval-union y-ext y))))
1264
1265 (define-builtin-markup-command (hcenter-in layout props length arg)
1266   (number? markup?)
1267   align
1268   ()
1269   "Center @var{arg} horizontally within a box of extending
1270 @var{length}/2 to the left and right."
1271   (interpret-markup layout props
1272                     (make-pad-to-box-markup
1273                      (cons (/ length -2) (/ length 2))
1274                      '(0 . 0)
1275                      (make-hcenter-markup arg))))
1276
1277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1278 ;; property
1279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1280
1281 (define-builtin-markup-command (fromproperty layout props symbol)
1282   (symbol?)
1283   other
1284   ()
1285   "Read the @var{symbol} from property settings, and produce a stencil
1286 from the markup contained within.  If @var{symbol} is not defined, it
1287 returns an empty markup."
1288   (let ((m (chain-assoc-get symbol props)))
1289     (if (markup? m)
1290         (interpret-markup layout props m)
1291         empty-stencil)))
1292
1293 (define-builtin-markup-command (on-the-fly layout props procedure arg)
1294   (symbol? markup?)
1295   other
1296   ()
1297   "Apply the @var{procedure} markup command to @var{arg}.
1298 @var{procedure} should take a single argument."
1299   (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
1300     (set-object-property! anonymous-with-signature
1301                           'markup-signature
1302                           (list markup?))
1303     (interpret-markup layout props (list anonymous-with-signature arg))))
1304
1305 (define-builtin-markup-command (override layout props new-prop arg)
1306   (pair? markup?)
1307   other
1308   ()
1309   "
1310 @cindex overriding properties within text markup
1311
1312 Add the first argument in to the property list.  Properties may be
1313 any sort of property supported by @rinternals{font-interface} and
1314 @rinternals{text-interface}, for example
1315
1316 @example
1317 \\override #'(font-family . married) \"bla\"
1318 @end example"
1319   (interpret-markup layout (cons (list new-prop) props) arg))
1320
1321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1322 ;; files
1323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1324
1325 (define-builtin-markup-command (verbatim-file layout props name)
1326   (string?)
1327   other
1328   ()
1329   "Read the contents of a file, and include it verbatim.
1330
1331 @lilypond[verbatim,quote]
1332 \\markup {
1333   \\verbatim-file #\"simple.ly\"
1334 }
1335 @end lilypond"
1336   (interpret-markup layout props
1337                     (if  (ly:get-option 'safe)
1338                          "verbatim-file disabled in safe mode"
1339                          (let* ((str (ly:gulp-file name))
1340                                 (lines (string-split str #\nl)))
1341                            (make-typewriter-markup
1342                             (make-column-markup lines))))))
1343
1344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1345 ;; fonts.
1346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1347
1348 (define-builtin-markup-command (bigger layout props arg)
1349   (markup?)
1350   font
1351   ()
1352   "Increase the font size relative to current setting.
1353
1354 @lilypond[verbatim,quote]
1355 \\markup {
1356   \\huge {
1357     huge
1358     \\hspace #2
1359     \\bigger {
1360       bigger
1361     }
1362     \\hspace #2
1363     huge
1364   }
1365 }
1366 @end lilypond"
1367   (interpret-markup layout props
1368    `(,fontsize-markup 1 ,arg)))
1369
1370 (define-builtin-markup-command (smaller layout props arg)
1371   (markup?)
1372   font
1373   ()
1374   "Decrease the font size relative to current setting.
1375
1376 @lilypond[verbatim,quote]
1377 \\markup {
1378   \\fontsize #3.5 {
1379     some large text
1380     \\hspace #2
1381     \\smaller {
1382       a bit smaller
1383     }
1384     \\hspace #2
1385     more large text
1386   }
1387 }
1388 @end lilypond"
1389   (interpret-markup layout props
1390    `(,fontsize-markup -1 ,arg)))
1391
1392 (define-builtin-markup-command (larger layout props arg)
1393   (markup?)
1394   font
1395   ()
1396   "Copy of the @code{\\bigger} command.
1397
1398 @lilypond[verbatim,quote]
1399 \\markup {
1400   default
1401   \\hspace #2
1402   \\larger
1403   larger
1404 }
1405 @end lilypond"
1406   (interpret-markup layout props (make-bigger-markup arg)))
1407
1408 (define-builtin-markup-command (finger layout props arg)
1409   (markup?)
1410   font
1411   ()
1412   "Set the argument as small numbers.
1413 @lilypond[verbatim,quote]
1414 \\markup {
1415   \\finger {
1416     1 2 3 4 5
1417   }
1418 }
1419 @end lilypond"
1420   (interpret-markup layout
1421                     (cons '((font-size . -5) (font-encoding . fetaNumber)) props)
1422                     arg))
1423
1424 (define-builtin-markup-command (abs-fontsize layout props size arg)
1425   (number? markup?)
1426   font
1427   ()
1428   "Use @var{size} as the absolute font size to display @var{arg}.
1429 Adjust baseline skip and word space accordingly.
1430 @lilypond[verbatim,quote]
1431 \\markup {
1432   default text font size
1433   \\hspace #2
1434   \\abs-fontsize #16 { text font size 16 }
1435   \\hspace #2
1436   \\abs-fontsize #12 { text font size 12 }
1437 }
1438 @end lilypond"
1439   (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12))
1440          (text-props (list (ly:output-def-lookup layout 'text-font-defaults)))
1441          (ref-word-space (chain-assoc-get 'word-space text-props 0.6))
1442          (ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
1443          (magnification (/ size ref-size)))
1444     (interpret-markup layout
1445                       (cons `((baseline-skip . ,(* magnification ref-baseline))
1446                               (word-space . ,(* magnification ref-word-space))
1447                               (font-size . ,(magnification->font-size magnification)))
1448                             props)
1449                       arg)))
1450
1451 (define-builtin-markup-command (fontsize layout props increment arg)
1452   (number? markup?)
1453   font
1454   ((font-size 0)
1455    (word-space 1)
1456    (baseline-skip 2))
1457   "Add @var{increment} to the font-size.  Adjust baseline skip accordingly.
1458 @lilypond[verbatim,quote]
1459 \\markup {
1460   default
1461   \\hspace #2
1462   \\fontsize #-1.5
1463   smaller
1464 }
1465 @end lilypond"
1466   (let ((entries (list
1467                   (cons 'baseline-skip (* baseline-skip (magstep increment)))
1468                   (cons 'word-space (* word-space (magstep increment)))
1469                   (cons 'font-size (+ font-size increment)))))
1470     (interpret-markup layout (cons entries props) arg)))
1471
1472 (define-builtin-markup-command (magnify layout props sz arg)
1473   (number? markup?)
1474   font
1475   ()
1476   "
1477 @cindex magnifying text
1478
1479 Set the font magnification for its argument.  In the following
1480 example, the middle@tie{}A is 10% larger:
1481
1482 @example
1483 A \\magnify #1.1 @{ A @} A
1484 @end example
1485
1486 Note: Magnification only works if a font name is explicitly selected.
1487 Use @code{\\fontsize} otherwise.
1488
1489 @lilypond[verbatim,quote]
1490 \\markup {
1491   default
1492   \\hspace #2
1493   \\magnify #1.5 {
1494     50% larger
1495   }
1496 }
1497 @end lilypond"
1498   (interpret-markup
1499    layout
1500    (prepend-alist-chain 'font-size (magnification->font-size sz) props)
1501    arg))
1502
1503 (define-builtin-markup-command (bold layout props arg)
1504   (markup?)
1505   font
1506   ()
1507   "Switch to bold font-series.
1508
1509 @lilypond[verbatim,quote]
1510 \\markup {
1511   default
1512   \\hspace #2
1513   \\bold
1514   bold
1515 }
1516 @end lilypond"
1517   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
1518
1519 (define-builtin-markup-command (sans layout props arg)
1520   (markup?)
1521   font
1522   ()
1523   "Switch to the sans serif family.
1524
1525 @lilypond[verbatim,quote]
1526 \\markup {
1527   default
1528   \\hspace #2
1529   \\sans {
1530     sans serif
1531   }
1532 }
1533 @end lilypond"
1534   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
1535
1536 (define-builtin-markup-command (number layout props arg)
1537   (markup?)
1538   font
1539   ()
1540   "Set font family to @code{number}, which yields the font used for
1541 time signatures and fingerings.  This font only contains numbers and
1542 some punctuation.  It doesn't have any letters.
1543
1544 @lilypond[verbatim,quote]
1545 \\markup {
1546   \\number {
1547     0 1 2 3 4 5 6 7 8 9 . ,
1548   }
1549 }
1550 @end lilypond"
1551   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaNumber props) arg))
1552
1553 (define-builtin-markup-command (roman layout props arg)
1554   (markup?)
1555   font
1556   ()
1557   "Set font family to @code{roman}.
1558
1559 @lilypond[verbatim,quote]
1560 \\markup {
1561   \\sans \\bold {
1562     sans serif, bold
1563     \\hspace #2
1564     \\roman {
1565       text in roman font family
1566     }
1567     \\hspace #2
1568     return to sans
1569   }
1570 }
1571 @end lilypond"
1572   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
1573
1574 (define-builtin-markup-command (huge layout props arg)
1575   (markup?)
1576   font
1577   ()
1578   "Set font size to +2.
1579
1580 @lilypond[verbatim,quote]
1581 \\markup {
1582   default
1583   \\hspace #2
1584   \\huge
1585   huge
1586 }
1587 @end lilypond"
1588   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
1589
1590 (define-builtin-markup-command (large layout props arg)
1591   (markup?)
1592   font
1593   ()
1594   "Set font size to +1.
1595
1596 @lilypond[verbatim,quote]
1597 \\markup {
1598   default
1599   \\hspace #2
1600   \\large
1601   large
1602 }
1603 @end lilypond"
1604   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
1605
1606 (define-builtin-markup-command (normalsize layout props arg)
1607   (markup?)
1608   font
1609   ()
1610   "Set font size to default.
1611
1612 @lilypond[verbatim,quote]
1613 \\markup {
1614   \\teeny {
1615     this is very small
1616     \\hspace #2
1617     \\normalsize {
1618       normal size
1619     }
1620     \\hspace #2
1621     teeny again
1622   }
1623 }
1624 @end lilypond"
1625   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
1626
1627 (define-builtin-markup-command (small layout props arg)
1628   (markup?)
1629   font
1630   ()
1631   "Set font size to -1.
1632
1633 @lilypond[verbatim,quote]
1634 \\markup {
1635   default
1636   \\hspace #2
1637   \\small
1638   small
1639 }
1640 @end lilypond"
1641   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
1642
1643 (define-builtin-markup-command (tiny layout props arg)
1644   (markup?)
1645   font
1646   ()
1647   "Set font size to -2.
1648
1649 @lilypond[verbatim,quote]
1650 \\markup {
1651   default
1652   \\hspace #2
1653   \\tiny
1654   tiny
1655 }
1656 @end lilypond"
1657   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
1658
1659 (define-builtin-markup-command (teeny layout props arg)
1660   (markup?)
1661   font
1662   ()
1663   "Set font size to -3.
1664
1665 @lilypond[verbatim,quote]
1666 \\markup {
1667   default
1668   \\hspace #2
1669   \\teeny
1670   teeny
1671 }
1672 @end lilypond"
1673   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
1674
1675 (define-builtin-markup-command (fontCaps layout props arg)
1676   (markup?)
1677   font
1678   ()
1679   "Set @code{font-shape} to @code{caps}"
1680   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
1681
1682 ;; Poor man's caps
1683 (define-builtin-markup-command (smallCaps layout props text)
1684   (markup?)
1685   font
1686   ()
1687   "Emit @var{arg} as small caps.
1688
1689 Note: @code{\\smallCaps} does not support accented characters.
1690
1691 @lilypond[verbatim,quote]
1692 \\markup {
1693   default
1694   \\hspace #2
1695   \\smallCaps {
1696     Text in small caps
1697   }
1698 }
1699 @end lilypond"
1700   (define (char-list->markup chars lower)
1701     (let ((final-string (string-upcase (reverse-list->string chars))))
1702       (if lower
1703           (markup #:fontsize -2 final-string)
1704           final-string)))
1705   (define (make-small-caps rest-chars currents current-is-lower prev-result)
1706     (if (null? rest-chars)
1707         (make-concat-markup
1708           (reverse! (cons (char-list->markup currents current-is-lower)
1709                           prev-result)))
1710         (let* ((ch (car rest-chars))
1711                (is-lower (char-lower-case? ch)))
1712           (if (or (and current-is-lower is-lower)
1713                   (and (not current-is-lower) (not is-lower)))
1714               (make-small-caps (cdr rest-chars)
1715                                (cons ch currents)
1716                                is-lower
1717                                prev-result)
1718               (make-small-caps (cdr rest-chars)
1719                                (list ch)
1720                                is-lower
1721                                (if (null? currents)
1722                                    prev-result
1723                                    (cons (char-list->markup
1724                                             currents current-is-lower)
1725                                          prev-result)))))))
1726   (interpret-markup layout props
1727     (if (string? text)
1728         (make-small-caps (string->list text) (list) #f (list))
1729         text)))
1730
1731 (define-builtin-markup-command (caps layout props arg)
1732   (markup?)
1733   font
1734   ()
1735   "Copy of the @code{\\smallCaps} command.
1736
1737 @lilypond[verbatim,quote]
1738 \\markup {
1739   default
1740   \\hspace #2
1741   \\caps {
1742     Text in small caps
1743   }
1744 }
1745 @end lilypond"
1746   (interpret-markup layout props (make-smallCaps-markup arg)))
1747
1748 (define-builtin-markup-command (dynamic layout props arg)
1749   (markup?)
1750   font
1751   ()
1752   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
1753 @b{z}, @b{p}, and @b{r}.  When producing phrases, like
1754 @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be
1755 done in a different font.  The recommended font for this is bold and italic.
1756 @lilypond[verbatim,quote]
1757 \\markup {
1758   \\dynamic {
1759     sfzp
1760   }
1761 }
1762 @end lilypond"
1763   (interpret-markup
1764    layout (prepend-alist-chain 'font-encoding 'fetaDynamic props) arg))
1765
1766 (define-builtin-markup-command (text layout props arg)
1767   (markup?)
1768   font
1769   ()
1770   "Use a text font instead of music symbol or music alphabet font.
1771
1772 @lilypond[verbatim,quote]
1773 \\markup {
1774   \\number {
1775     1, 2,
1776     \\text {
1777       three, four,
1778     }
1779     5
1780   }
1781 }
1782 @end lilypond"
1783
1784   ;; ugh - latin1
1785   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
1786                     arg))
1787
1788 (define-builtin-markup-command (italic layout props arg)
1789   (markup?)
1790   font
1791   ()
1792   "Use italic @code{font-shape} for @var{arg}.
1793
1794 @lilypond[verbatim,quote]
1795 \\markup {
1796   default
1797   \\hspace #2
1798   \\italic
1799   italic
1800 }
1801 @end lilypond"
1802   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
1803
1804 (define-builtin-markup-command (typewriter layout props arg)
1805   (markup?)
1806   font
1807   ()
1808   "Use @code{font-family} typewriter for @var{arg}.
1809
1810 @lilypond[verbatim,quote]
1811 \\markup {
1812   default
1813   \\hspace #2
1814   \\typewriter
1815   typewriter
1816 }
1817 @end lilypond"
1818   (interpret-markup
1819    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
1820
1821 (define-builtin-markup-command (upright layout props arg)
1822   (markup?)
1823   font
1824   ()
1825   "Set font shape to @code{upright}.  This is the opposite of @code{italic}.
1826
1827 @lilypond[verbatim,quote]
1828 \\markup {
1829   \\italic {
1830     italic text
1831     \\hspace #2
1832     \\upright {
1833       upright text
1834     }
1835     \\hspace #2
1836     italic again
1837   }
1838 }
1839 @end lilypond"
1840   (interpret-markup
1841    layout (prepend-alist-chain 'font-shape 'upright props) arg))
1842
1843 (define-builtin-markup-command (medium layout props arg)
1844   (markup?)
1845   font
1846   ()
1847   "Switch to medium font series (in contrast to bold).
1848
1849 @lilypond[verbatim,quote]
1850 \\markup {
1851   \\bold {
1852     some bold text
1853     \\hspace #2
1854     \\medium {
1855       medium font series
1856     }
1857     \\hspace #2
1858     bold again
1859   }
1860 }
1861 @end lilypond"
1862   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
1863                     arg))
1864
1865 (define-builtin-markup-command (normal-text layout props arg)
1866   (markup?)
1867   font
1868   ()
1869   "Set all font related properties (except the size) to get the default
1870 normal text font, no matter what font was used earlier.
1871
1872 @lilypond[verbatim,quote]
1873 \\markup {
1874   \\huge \\bold \\sans \\caps {
1875     Some text with font overrides
1876     \\hspace #2
1877     \\normal-text {
1878       Default text, same font-size
1879     }
1880     \\hspace #2
1881     More text as before
1882   }
1883 }
1884 @end lilypond"
1885   ;; ugh - latin1
1886   (interpret-markup layout
1887                     (cons '((font-family . roman) (font-shape . upright)
1888                             (font-series . medium) (font-encoding . latin1))
1889                           props)
1890                     arg))
1891
1892 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1893 ;; symbols.
1894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1895
1896 (define-builtin-markup-command (doublesharp layout props)
1897   ()
1898   music
1899   ()
1900   "Draw a double sharp symbol.
1901
1902 @lilypond[verbatim,quote]
1903 \\markup {
1904   \\doublesharp
1905 }
1906 @end lilypond"
1907   (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist ""))))
1908
1909 (define-builtin-markup-command (sesquisharp layout props)
1910   ()
1911   music
1912   ()
1913   "Draw a 3/2 sharp symbol.
1914
1915 @lilypond[verbatim,quote]
1916 \\markup {
1917   \\sesquisharp
1918 }
1919 @end lilypond"
1920   (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist ""))))
1921
1922 (define-builtin-markup-command (sharp layout props)
1923   ()
1924   music
1925   ()
1926   "Draw a sharp symbol.
1927
1928 @lilypond[verbatim,quote]
1929 \\markup {
1930   \\sharp
1931 }
1932 @end lilypond"
1933   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist ""))))
1934
1935 (define-builtin-markup-command (semisharp layout props)
1936   ()
1937   music
1938   ()
1939   "Draw a semi sharp symbol.
1940
1941 @lilypond[verbatim,quote]
1942 \\markup {
1943   \\semisharp
1944 }
1945 @end lilypond"
1946   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist ""))))
1947
1948 (define-builtin-markup-command (natural layout props)
1949   ()
1950   music
1951   ()
1952   "Draw a natural symbol.
1953
1954 @lilypond[verbatim,quote]
1955 \\markup {
1956   \\natural
1957 }
1958 @end lilypond"
1959   (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist ""))))
1960
1961 (define-builtin-markup-command (semiflat layout props)
1962   ()
1963   music
1964   ()
1965   "Draw a semiflat symbol.
1966
1967 @lilypond[verbatim,quote]
1968 \\markup {
1969   \\semiflat
1970 }
1971 @end lilypond"
1972   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist ""))))
1973
1974 (define-builtin-markup-command (flat layout props)
1975   ()
1976   music
1977   ()
1978   "Draw a flat symbol.
1979
1980 @lilypond[verbatim,quote]
1981 \\markup {
1982   \\flat
1983 }
1984 @end lilypond"
1985   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist ""))))
1986
1987 (define-builtin-markup-command (sesquiflat layout props)
1988   ()
1989   music
1990   ()
1991   "Draw a 3/2 flat symbol.
1992
1993 @lilypond[verbatim,quote]
1994 \\markup {
1995   \\sesquiflat
1996 }
1997 @end lilypond"
1998   (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist ""))))
1999
2000 (define-builtin-markup-command (doubleflat layout props)
2001   ()
2002   music
2003   ()
2004   "Draw a double flat symbol.
2005
2006 @lilypond[verbatim,quote]
2007 \\markup {
2008   \\doubleflat
2009 }
2010 @end lilypond"
2011   (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist ""))))
2012
2013 (define-builtin-markup-command (with-color layout props color arg)
2014   (color? markup?)
2015   other
2016   ()
2017   "
2018 @cindex coloring text
2019
2020 Draw @var{arg} in color specified by @var{color}."
2021   (let ((stil (interpret-markup layout props arg)))
2022     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
2023                      (ly:stencil-extent stil X)
2024                      (ly:stencil-extent stil Y))))
2025 \f
2026 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2027 ;; glyphs
2028 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2029
2030 (define-builtin-markup-command (arrow-head layout props axis direction filled)
2031   (integer? ly:dir? boolean?)
2032   graphic
2033   ()
2034   "Produce an arrow head in specified direction and axis.
2035 Use the filled head if @var{filled} is specified.
2036 @lilypond[verbatim,quote]
2037 \\markup {
2038   \\fontsize #5 {
2039     \\general-align #Y #DOWN {
2040       \\arrow-head #Y #UP ##t
2041       \\arrow-head #Y #DOWN ##f
2042       \\hspace #2
2043       \\arrow-head #X #RIGHT ##f
2044       \\arrow-head #X #LEFT ##f
2045     }
2046   }
2047 }
2048 @end lilypond"
2049   (let*
2050       ((name (format "arrowheads.~a.~a~a"
2051                      (if filled
2052                          "close"
2053                          "open")
2054                      axis
2055                      direction)))
2056     (ly:font-get-glyph
2057      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
2058                                      props))
2059      name)))
2060
2061 (define-builtin-markup-command (musicglyph layout props glyph-name)
2062   (string?)
2063   music
2064   ()
2065   "@var{glyph-name} is converted to a musical symbol; for example,
2066 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
2067 the music font.  See @ruser{The Feta font} for a complete listing of
2068 the possible glyphs.
2069
2070 @lilypond[verbatim,quote]
2071 \\markup {
2072   \\musicglyph #\"f\"
2073   \\musicglyph #\"rests.2\"
2074   \\musicglyph #\"clefs.G_change\"
2075 }
2076 @end lilypond"
2077   (let* ((font (ly:paper-get-font layout
2078                                   (cons '((font-encoding . fetaMusic)
2079                                           (font-name . #f))
2080
2081                                                  props)))
2082          (glyph (ly:font-get-glyph font glyph-name)))
2083     (if (null? (ly:stencil-expr glyph))
2084         (ly:warning (_ "Cannot find glyph ~a") glyph-name))
2085
2086     glyph))
2087
2088
2089 (define-builtin-markup-command (lookup layout props glyph-name)
2090   (string?)
2091   other
2092   ()
2093   "Lookup a glyph by name.
2094
2095 @lilypond[verbatim,quote]
2096 \\markup {
2097   \\override #'(font-encoding . fetaBraces) {
2098     \\lookup #\"brace200\"
2099     \\hspace #2
2100     \\rotate #180
2101     \\lookup #\"brace180\"
2102   }
2103 }
2104 @end lilypond"
2105   (ly:font-get-glyph (ly:paper-get-font layout props)
2106                      glyph-name))
2107
2108 (define-builtin-markup-command (char layout props num)
2109   (integer?)
2110   other
2111   ()
2112   "Produce a single character.  For example, @code{\\char #65} produces the
2113 letter @q{A}."
2114   (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num)))
2115
2116 (define number->mark-letter-vector (make-vector 25 #\A))
2117
2118 (do ((i 0 (1+ i))
2119      (j 0 (1+ j)))
2120     ((>= i 26))
2121   (if (= i (- (char->integer #\I) (char->integer #\A)))
2122       (set! i (1+ i)))
2123   (vector-set! number->mark-letter-vector j
2124                (integer->char (+ i (char->integer #\A)))))
2125
2126 (define number->mark-alphabet-vector (list->vector
2127   (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
2128
2129 (define (number->markletter-string vec n)
2130   "Double letters for big marks."
2131   (let* ((lst (vector-length vec)))
2132
2133     (if (>= n lst)
2134         (string-append (number->markletter-string vec (1- (quotient n lst)))
2135                        (number->markletter-string vec (remainder n lst)))
2136         (make-string 1 (vector-ref vec n)))))
2137
2138 (define-builtin-markup-command (markletter layout props num)
2139   (integer?)
2140   other
2141   ()
2142   "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
2143 (skipping letter@tie{}I), and continue with double letters.
2144
2145 @lilypond[verbatim,quote]
2146 \\markup {
2147   \\markletter #8
2148   \\hspace #2
2149   \\markletter #26
2150 }
2151 @end lilypond"
2152   (ly:text-interface::interpret-markup layout props
2153     (number->markletter-string number->mark-letter-vector num)))
2154
2155 (define-builtin-markup-command (markalphabet layout props num)
2156   (integer?)
2157   other
2158   ()
2159    "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
2160 and continue with double letters.
2161
2162 @lilypond[verbatim,quote]
2163 \\markup {
2164   \\markalphabet #8
2165   \\hspace #2
2166   \\markalphabet #26
2167 }
2168 @end lilypond"
2169    (ly:text-interface::interpret-markup layout props
2170      (number->markletter-string number->mark-alphabet-vector num)))
2171
2172 (define-public (horizontal-slash-interval num forward number-interval mag)
2173   (ly:message "Mag step: ~a" mag)
2174   (if forward
2175     (cond ;((= num 6) (interval-widen number-interval (* mag 0.5)))
2176           ;((= num 5) (interval-widen number-interval (* mag 0.5)))
2177           (else (interval-widen number-interval (* mag 0.25))))
2178     (cond ((= num 6) (interval-widen number-interval (* mag 0.5)))
2179           ;((= num 5) (interval-widen number-interval (* mag 0.5)))
2180           (else (interval-widen number-interval (* mag 0.25))))
2181   ))
2182
2183 (define-public (adjust-slash-stencil num forward stencil mag)
2184   (if forward
2185     (cond ((= num 2)
2186               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
2187           ((= num 3)
2188               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2))))
2189           ;((= num 5)
2190               ;(ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07))))
2191           ;((= num 7)
2192           ;    (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
2193           (else stencil))
2194     (cond ((= num 6)
2195               (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15))))
2196           ;((= num 8)
2197           ;    (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15))))
2198           (else stencil))
2199   )
2200 )
2201
2202 (define (slashed-digit-internal layout props num forward font-size thickness)
2203   (let* ((mag (magstep font-size))
2204          (thickness (* mag
2205                        (ly:output-def-lookup layout 'line-thickness)
2206                        thickness))
2207          ; backward slashes might use slope and point in the other direction!
2208          (dy (* mag (if forward 0.4 -0.4)))
2209          (number-stencil (interpret-markup layout
2210                                            (prepend-alist-chain 'font-encoding 'fetaNumber props)
2211                                            (number->string num)))
2212          (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag))
2213          (center (interval-center (ly:stencil-extent number-stencil Y)))
2214          ; Use the real extents of the slash, not the whole number, because we
2215          ; might translate the slash later on!
2216          (num-y (interval-widen (cons center center) (abs dy)))
2217          (is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
2218          (slash-stencil (if is-sane
2219                             (ly:make-stencil
2220                              `(draw-line ,thickness
2221                                          ,(car num-x) ,(- (interval-center num-y) dy)
2222                                          ,(cdr num-x) ,(+ (interval-center num-y) dy))
2223                              num-x num-y)
2224                             #f)))
2225 (ly:message "Num: ~a, X-interval: ~a" num num-x)
2226     (if (ly:stencil? slash-stencil)
2227       (begin
2228         ; for some numbers we need to shift the slash/backslash up or down to make
2229         ; the slashed digit look better
2230         (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag))
2231         (set! number-stencil
2232           (ly:stencil-add number-stencil slash-stencil)))
2233       (ly:warning "Unable to create slashed digit ~a" num))
2234     number-stencil))
2235
2236
2237 (define-builtin-markup-command (slashed-digit layout props num)
2238   (integer?)
2239   other
2240   ((font-size 0)
2241    (thickness 1.6))
2242   "
2243 @cindex slashed digits
2244
2245 A feta number, with slash.  This is for use in the context of
2246 figured bass notation.
2247 @lilypond[verbatim,quote]
2248 \\markup {
2249   \\slashed-digit #5
2250   \\hspace #2
2251   \\override #'(thickness . 3)
2252   \\slashed-digit #7
2253 }
2254 @end lilypond"
2255   (slashed-digit-internal layout props num #t font-size thickness))
2256
2257 (define-builtin-markup-command (backslashed-digit layout props num)
2258   (integer?)
2259   other
2260   ((font-size 0)
2261    (thickness 1.6))
2262   "
2263 @cindex backslashed digits
2264
2265 A feta number, with backslash.  This is for use in the context of
2266 figured bass notation.
2267 @lilypond[verbatim,quote]
2268 \\markup {
2269   \\backslashed-digit #5
2270   \\hspace #2
2271   \\override #'(thickness . 3)
2272   \\backslashed-digit #7
2273 }
2274 @end lilypond"
2275   (slashed-digit-internal layout props num #f font-size thickness))
2276
2277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2278 ;; the note command.
2279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2280
2281 ;; TODO: better syntax.
2282
2283 (define-builtin-markup-command (note-by-number layout props log dot-count dir)
2284   (number? number? number?)
2285   music
2286   ((font-size 0)
2287    (style '()))
2288   "
2289 @cindex notes within text by log and dot-count
2290
2291 Construct a note symbol, with stem.  By using fractional values for
2292 @var{dir}, you can obtain longer or shorter stems.
2293
2294 @lilypond[verbatim,quote]
2295 \\markup {
2296   \\note-by-number #3 #0 #DOWN
2297   \\hspace #2
2298   \\note-by-number #1 #2 #0.8
2299 }
2300 @end lilypond"
2301   (define (get-glyph-name-candidates dir log style)
2302     (map (lambda (dir-name)
2303      (format "noteheads.~a~a~a" dir-name (min log 2)
2304              (if (and (symbol? style)
2305                       (not (equal? 'default style)))
2306                  (symbol->string style)
2307                  "")))
2308          (list (if (= dir UP) "u" "d")
2309                "s")))
2310
2311   (define (get-glyph-name font cands)
2312     (if (null? cands)
2313      ""
2314      (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
2315          (get-glyph-name font (cdr cands))
2316          (car cands))))
2317
2318   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) props)))
2319          (size-factor (magstep font-size))
2320          (stem-length (*  size-factor (max 3 (- log 1))))
2321          (head-glyph-name (get-glyph-name font (get-glyph-name-candidates (sign dir) log style)))
2322          (head-glyph (ly:font-get-glyph font head-glyph-name))
2323          (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
2324          (stem-thickness (* size-factor 0.13))
2325          (stemy (* dir stem-length))
2326          (attach-off (cons (interval-index
2327                             (ly:stencil-extent head-glyph X)
2328                             (* (sign dir) (car attach-indices)))
2329                            (* (sign dir)        ; fixme, this is inconsistent between X & Y.
2330                               (interval-index
2331                                (ly:stencil-extent head-glyph Y)
2332                                (cdr attach-indices)))))
2333          (stem-glyph (and (> log 0)
2334                           (ly:round-filled-box
2335                            (ordered-cons (car attach-off)
2336                                          (+ (car attach-off)  (* (- (sign dir)) stem-thickness)))
2337                            (cons (min stemy (cdr attach-off))
2338                                  (max stemy (cdr attach-off)))
2339                            (/ stem-thickness 3))))
2340
2341          (dot (ly:font-get-glyph font "dots.dot"))
2342          (dotwid (interval-length (ly:stencil-extent dot X)))
2343          (dots (and (> dot-count 0)
2344                     (apply ly:stencil-add
2345                            (map (lambda (x)
2346                                   (ly:stencil-translate-axis
2347                                    dot (* 2 x dotwid) X))
2348                                 (iota dot-count)))))
2349          (flaggl (and (> log 2)
2350                       (ly:stencil-translate
2351                        (ly:font-get-glyph font
2352                                           (string-append "flags."
2353                                                          (if (> dir 0) "u" "d")
2354                                                          (number->string log)))
2355                        (cons (+ (car attach-off) (if (< dir 0) stem-thickness 0)) stemy)))))
2356
2357     ; If there is a flag on an upstem and the stem is short, move the dots to avoid the flag.
2358     ; 16th notes get a special case because their flags hang lower than any other flags.
2359     (if (and dots (> dir 0) (> log 2) (or (< dir 1.15) (and (= log 4) (< dir 1.3))))
2360         (set! dots (ly:stencil-translate-axis dots 0.5 X)))
2361     (if flaggl
2362         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
2363     (if (ly:stencil? stem-glyph)
2364         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
2365         (set! stem-glyph head-glyph))
2366     (if (ly:stencil? dots)
2367         (set! stem-glyph
2368               (ly:stencil-add
2369                (ly:stencil-translate-axis
2370                 dots
2371                 (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
2372                 X)
2373                stem-glyph)))
2374     stem-glyph))
2375
2376 (define-public log2
2377   (let ((divisor (log 2)))
2378     (lambda (z) (inexact->exact (/ (log z) divisor)))))
2379
2380 (define (parse-simple-duration duration-string)
2381   "Parse the `duration-string', e.g. ''4..'' or ''breve.'', and return a (log dots) list."
2382   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string)))
2383     (if (and match (string=? duration-string (match:substring match 0)))
2384         (let ((len  (match:substring match 1))
2385               (dots (match:substring match 2)))
2386           (list (cond ((string=? len "breve") -1)
2387                       ((string=? len "longa") -2)
2388                       ((string=? len "maxima") -3)
2389                       (else (log2 (string->number len))))
2390                 (if dots (string-length dots) 0)))
2391         (ly:error (_ "not a valid duration string: ~a") duration-string))))
2392
2393 (define-builtin-markup-command (note layout props duration dir)
2394   (string? number?)
2395   music
2396   (note-by-number-markup)
2397   "
2398 @cindex notes within text by string
2399
2400 This produces a note with a stem pointing in @var{dir} direction, with
2401 the @var{duration} for the note head type and augmentation dots.  For
2402 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
2403 a shortened down stem.
2404
2405 @lilypond[verbatim,quote]
2406 \\markup {
2407   \\override #'(style . cross) {
2408     \\note #\"4..\" #UP
2409   }
2410   \\hspace #2
2411   \\note #\"breve\" #0
2412 }
2413 @end lilypond"
2414   (let ((parsed (parse-simple-duration duration)))
2415     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
2416 \f
2417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2418 ;; translating.
2419 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2420
2421 (define-builtin-markup-command (lower layout props amount arg)
2422   (number? markup?)
2423   align
2424   ()
2425   "
2426 @cindex lowering text
2427
2428 Lower @var{arg} by the distance @var{amount}.
2429 A negative @var{amount} indicates raising; see also @code{\\raise}."
2430   (ly:stencil-translate-axis (interpret-markup layout props arg)
2431                              (- amount) Y))
2432
2433 (define-builtin-markup-command (translate-scaled layout props offset arg)
2434   (number-pair? markup?)
2435   other
2436   ((font-size 0))
2437   "
2438 @cindex translating text
2439 @cindex scaling text
2440
2441 Translate @var{arg} by @var{offset}, scaling the offset by the
2442 @code{font-size}."
2443   (let* ((factor (magstep font-size))
2444          (scaled (cons (* factor (car offset))
2445                        (* factor (cdr offset)))))
2446     (ly:stencil-translate (interpret-markup layout props arg)
2447                           scaled)))
2448
2449 (define-builtin-markup-command (raise layout props amount arg)
2450   (number? markup?)
2451   align
2452   ()
2453   "
2454 @cindex raising text
2455
2456 Raise @var{arg} by the distance @var{amount}.
2457 A negative @var{amount} indicates lowering, see also @code{\\lower}.
2458
2459 The argument to @code{\\raise} is the vertical displacement amount,
2460 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
2461 raise objects in relation to their surrounding markups.
2462
2463 If the text object itself is positioned above or below the staff, then
2464 @code{\\raise} cannot be used to move it, since the mechanism that
2465 positions it next to the staff cancels any shift made with
2466 @code{\\raise}.  For vertical positioning, use the @code{padding}
2467 and/or @code{extra-offset} properties.
2468
2469 @lilypond[verbatim,quote]
2470 \\markup {
2471   C
2472   \\small
2473   \\bold
2474   \\raise #1.0
2475   9/7+
2476 }
2477 @end lilypond"
2478   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
2479
2480 (define-builtin-markup-command (fraction layout props arg1 arg2)
2481   (markup? markup?)
2482   other
2483   ((font-size 0))
2484   "
2485 @cindex creating text fractions
2486
2487 Make a fraction of two markups.
2488 @lilypond[verbatim,quote]
2489 \\markup {
2490   π ≈
2491   \\fraction 355 113
2492 }
2493 @end lilypond"
2494   (let* ((m1 (interpret-markup layout props arg1))
2495          (m2 (interpret-markup layout props arg2))
2496          (factor (magstep font-size))
2497          (boxdimen (cons (* factor -0.05) (* factor 0.05)))
2498          (padding (* factor 0.2))
2499          (baseline (* factor 0.6))
2500          (offset (* factor 0.75)))
2501     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
2502     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
2503     (let* ((x1 (ly:stencil-extent m1 X))
2504            (x2 (ly:stencil-extent m2 X))
2505            (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
2506            ;; should stack mols separately, to maintain LINE on baseline
2507            (stack (stack-lines DOWN padding baseline (list m1 line m2))))
2508       (set! stack
2509             (ly:stencil-aligned-to stack Y CENTER))
2510       (set! stack
2511             (ly:stencil-aligned-to stack X LEFT))
2512       ;; should have EX dimension
2513       ;; empirical anyway
2514       (ly:stencil-translate-axis stack offset Y))))
2515
2516 (define-builtin-markup-command (normal-size-super layout props arg)
2517   (markup?)
2518   font
2519   ((baseline-skip))
2520   "
2521 @cindex setting superscript in standard font size
2522
2523 Set @var{arg} in superscript with a normal font size.
2524
2525 @lilypond[verbatim,quote]
2526 \\markup {
2527   default
2528   \\normal-size-super {
2529     superscript in standard size
2530   }
2531 }
2532 @end lilypond"
2533   (ly:stencil-translate-axis
2534    (interpret-markup layout props arg)
2535    (* 0.5 baseline-skip) Y))
2536
2537 (define-builtin-markup-command (super layout props arg)
2538   (markup?)
2539   font
2540   ((font-size 0)
2541    (baseline-skip))
2542   "
2543 @cindex superscript text
2544
2545 Raising and lowering texts can be done with @code{\\super} and
2546 @code{\\sub}:
2547
2548 @lilypond[verbatim,quote]
2549 \\markup {
2550   E =
2551   \\concat {
2552     mc
2553     \\super
2554     2
2555   }
2556 }
2557 @end lilypond"
2558   (ly:stencil-translate-axis
2559    (interpret-markup
2560     layout
2561     (cons `((font-size . ,(- font-size 3))) props)
2562     arg)
2563    (* 0.5 baseline-skip)
2564    Y))
2565
2566 (define-builtin-markup-command (translate layout props offset arg)
2567   (number-pair? markup?)
2568   align
2569   ()
2570   "
2571 @cindex translating text
2572
2573 This translates an object.  Its first argument is a cons of numbers.
2574
2575 @example
2576 A \\translate #(cons 2 -3) @{ B C @} D
2577 @end example
2578
2579 This moves @q{B C} 2@tie{}spaces to the right, and 3 down, relative to its
2580 surroundings.  This command cannot be used to move isolated scripts
2581 vertically, for the same reason that @code{\\raise} cannot be used for
2582 that."
2583   (ly:stencil-translate (interpret-markup  layout props arg)
2584                         offset))
2585
2586 (define-builtin-markup-command (sub layout props arg)
2587   (markup?)
2588   font
2589   ((font-size 0)
2590    (baseline-skip))
2591   "
2592 @cindex subscript text
2593
2594 Set @var{arg} in subscript.
2595
2596 @lilypond[verbatim,quote]
2597 \\markup {
2598   \\concat {
2599     H
2600     \\sub {
2601       2
2602     }
2603     O
2604   }
2605 }
2606 @end lilypond"
2607   (ly:stencil-translate-axis
2608    (interpret-markup
2609     layout
2610     (cons `((font-size . ,(- font-size 3))) props)
2611     arg)
2612    (* -0.5 baseline-skip)
2613    Y))
2614
2615 (define-builtin-markup-command (normal-size-sub layout props arg)
2616   (markup?)
2617   font
2618   ((baseline-skip))
2619   "
2620 @cindex setting subscript in standard font size
2621
2622 Set @var{arg} in subscript, in a normal font size.
2623
2624 @lilypond[verbatim,quote]
2625 \\markup {
2626   default
2627   \\normal-size-sub {
2628     subscript in standard size
2629   }
2630 }
2631 @end lilypond"
2632   (ly:stencil-translate-axis
2633    (interpret-markup layout props arg)
2634    (* -0.5 baseline-skip)
2635    Y))
2636 \f
2637 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2638 ;; brackets.
2639 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2640
2641 (define-builtin-markup-command (hbracket layout props arg)
2642   (markup?)
2643   graphic
2644   ()
2645   "
2646 @cindex placing horizontal brackets around text
2647
2648 Draw horizontal brackets around @var{arg}.
2649
2650 @lilypond[verbatim,quote]
2651 \\markup {
2652   \\hbracket {
2653     \\line {
2654       one two three
2655     }
2656   }
2657 }
2658 @end lilypond"
2659   (let ((th 0.1) ;; todo: take from GROB.
2660         (m (interpret-markup layout props arg)))
2661     (bracketify-stencil m X th (* 2.5 th) th)))
2662
2663 (define-builtin-markup-command (bracket layout props arg)
2664   (markup?)
2665   graphic
2666   ()
2667   "
2668 @cindex placing vertical brackets around text
2669
2670 Draw vertical brackets around @var{arg}.
2671
2672 @lilypond[verbatim,quote]
2673 \\markup {
2674   \\bracket {
2675     \\note #\"2.\" #UP
2676   }
2677 }
2678 @end lilypond"
2679   (let ((th 0.1) ;; todo: take from GROB.
2680         (m (interpret-markup layout props arg)))
2681     (bracketify-stencil m Y th (* 2.5 th) th)))
2682 \f
2683 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2684 ;; Delayed markup evaluation
2685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2686
2687 (define-builtin-markup-command (page-ref layout props label gauge default)
2688   (symbol? markup? markup?)
2689   other
2690   ()
2691   "
2692 @cindex referencing page numbers in text
2693
2694 Reference to a page number. @var{label} is the label set on the referenced
2695 page (using the @code{\\label} command), @var{gauge} a markup used to estimate
2696 the maximum width of the page number, and @var{default} the value to display
2697 when @var{label} is not found."
2698   (let* ((gauge-stencil (interpret-markup layout props gauge))
2699          (x-ext (ly:stencil-extent gauge-stencil X))
2700          (y-ext (ly:stencil-extent gauge-stencil Y)))
2701     (ly:make-stencil
2702      `(delay-stencil-evaluation
2703        ,(delay (ly:stencil-expr
2704                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
2705                        (label-page (and (list? table) (assoc label table)))
2706                        (page-number (and label-page (cdr label-page)))
2707                        (page-markup (if page-number (format "~a" page-number) default))
2708                        (page-stencil (interpret-markup layout props page-markup))
2709                        (gap (- (interval-length x-ext)
2710                                (interval-length (ly:stencil-extent page-stencil X)))))
2711                   (interpret-markup layout props
2712                                     (markup #:concat (#:hspace gap page-markup)))))))
2713      x-ext
2714      y-ext)))
2715 \f
2716 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2717 ;; Markup list commands
2718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2719
2720 (define-public (space-lines baseline stils)
2721   (let space-stil ((prev-stil #f)
2722                    (stils stils)
2723                    (result (list)))
2724     (cond ((null? stils)
2725            (reverse! result))
2726           ((not prev-stil)
2727            (space-stil (car stils) (cdr stils) (list (car stils))))
2728           (else
2729            (let* ((stil (car stils))
2730                   (dy (max (- baseline
2731                               (+ (- (interval-bound (ly:stencil-extent prev-stil Y) DOWN))
2732                                  (interval-bound (ly:stencil-extent stil Y) UP)))
2733                            0.0))
2734                   (new-stil (ly:make-stencil
2735                              (ly:stencil-expr stil)
2736                              (ly:stencil-extent stil X)
2737                              (cons (interval-bound (ly:stencil-extent stil Y) DOWN)
2738                                    (+ (interval-bound (ly:stencil-extent stil Y) UP) dy)))))
2739              (space-stil stil (cdr stils) (cons new-stil result)))))))
2740
2741 (define-builtin-markup-list-command (justified-lines layout props args)
2742   (markup-list?)
2743   ((baseline-skip)
2744    wordwrap-internal-markup-list)
2745   "
2746 @cindex justifying lines of text
2747
2748 Like @code{\\justify}, but return a list of lines instead of a single markup.
2749 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
2750 @var{X}@tie{}is the number of staff spaces."
2751   (space-lines baseline-skip
2752                (interpret-markup-list layout props
2753                                       (make-wordwrap-internal-markup-list #t args))))
2754
2755 (define-builtin-markup-list-command (wordwrap-lines layout props args)
2756   (markup-list?)
2757   ((baseline-skip)
2758    wordwrap-internal-markup-list)
2759   "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
2760 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
2761 where @var{X} is the number of staff spaces."
2762   (space-lines baseline-skip
2763                (interpret-markup-list layout props
2764                                       (make-wordwrap-internal-markup-list #f args))))
2765
2766 (define-builtin-markup-list-command (column-lines layout props args)
2767   (markup-list?)
2768   ((baseline-skip))
2769   "Like @code{\\column}, but return a list of lines instead of a single markup.
2770 @code{baseline-skip} determines the space between each markup in @var{args}."
2771   (space-lines (chain-assoc-get 'baseline-skip props)
2772                (interpret-markup-list layout props args)))
2773
2774 (define-builtin-markup-list-command (override-lines layout props new-prop args)
2775   (pair? markup-list?)
2776   ()
2777   "Like @code{\\override}, for markup lists."
2778   (interpret-markup-list layout (cons (list new-prop) props) args))