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   "
  29 @cindex drawing lines within text
  30
  31 A simple line.  Uses the @code{thickness} property."
  32   (let*
  33       ((th (*
  34             (ly:output-def-lookup layout 'line-thickness)
  35             (chain-assoc-get 'thickness props 1)))
  36        (x (car dest))
  37        (y (cdr dest))
  38        (s (ly:make-stencil
  39            `(draw-line
  40              ,th
  41              0 0
  42              ,x ,y)
  43
  44            (cons (min x 0) (max x 0))
  45            (cons (min y 0) (max y 0)))))
  46
  47     s))
  48
  49 (define-builtin-markup-command (draw-circle layout props radius thickness fill)
  50   (number? number? boolean?)
  51   "
  52 @cindex drawing circles within text
  53
  54 A circle of radius @var{radius}, thickness @var{thickness} and
  55 optionally filled.
  56 @c
  57 @lilypond[verbatim,quote]
  58 \\markup { \\draw-circle #2 #0.5 ##f \\hspace #2 \\draw-circle #2 #0 ##t }
  59 @end lilypond"
  60   (make-circle-stencil radius thickness fill))
  61
  62 (define-builtin-markup-command (triangle layout props filled) (boolean?)
  63   "
  64 @cindex drawing triangles within text
  65
  66 A triangle, either filled or empty.
  67 @c
  68 @lilypond[verbatim,quote]
  69 \\markup { \\triangle ##f \\triangle ##t }
  70 @end lilypond"
  71   (let*
  72       ((th (chain-assoc-get 'thickness props  0.1))
  73        (size (chain-assoc-get 'font-size props 0))
  74        (ex (* (magstep size)
  75               0.8
  76               (chain-assoc-get 'baseline-skip props 2))))
  77
  78     (ly:make-stencil
  79      `(polygon '(0.0 0.0
  80                      ,ex 0.0
  81                      ,(* 0.5 ex)
  82                      ,(* 0.86 ex))
  83            ,th
  84            ,filled)
  85
  86      (cons 0 ex)
  87      (cons 0 (* .86 ex))
  88      )))
  89
  90 (define-builtin-markup-command (circle layout props arg) (markup?)
  91   "
  92 @cindex circling text
  93
  94 Draw a circle around @var{arg}.  Use @code{thickness},
  95 @code{circle-padding} and @code{font-size} properties to determine line
  96 thickness and padding around the markup."
  97
  98   (let* ((th
  99           (* (ly:output-def-lookup layout 'line-thickness)
 100              (chain-assoc-get 'thickness props  1)))
 101          (size (chain-assoc-get 'font-size props 0))
 102          (pad
 103           (* (magstep size)
 104              (chain-assoc-get 'circle-padding props 0.2)))
 105          (m (interpret-markup layout props arg)))
 106     (circle-stencil m th pad)))
 107
 108 (define-builtin-markup-command (with-url layout props url arg) (string? markup?)
 109   "
 110 @cindex inserting URL links into text
 111
 112 Add a link to URL @var{url} around @var{arg}.  This only works in
 113 the PDF backend.
 114 @lilypond[verbatim,quote]
 115 \\markup {
 116   \\with-url #\"http://lilypond.org/web/\" {
 117     LilyPond ... \\italic \"music notation for everyone\"
 118   }
 119 }
 120 @end lilypond"
 121   (let* ((stil (interpret-markup layout props arg))
 122          (xextent (ly:stencil-extent stil X))
 123          (yextent (ly:stencil-extent stil Y))
 124          (old-expr (ly:stencil-expr stil))
 125          (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
 126
 127     (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
 128
 129 (define-builtin-markup-command (beam layout props width slope thickness)
 130   (number? number? number?)
 131   "
 132 @cindex drawing beams within text
 133
 134 Create a beam with the specified parameters."
 135   (let* ((y (* slope width))
 136          (yext (cons (min 0 y) (max 0 y)))
 137          (half (/ thickness 2)))
 138
 139     (ly:make-stencil
 140      `(polygon ',(list
 141                   0 (/ thickness -2)
 142                     width (+ (* width slope)  (/ thickness -2))
 143                     width (+ (* width slope)  (/ thickness 2))
 144                     0 (/ thickness 2))
 145                ,(ly:output-def-lookup layout 'blot-diameter)
 146                #t)
 147      (cons 0 width)
 148      (cons (+ (- half) (car yext))
 149            (+ half (cdr yext))))))
 150
 151 (define-builtin-markup-command (underline layout props arg) (markup?)
 152   "
 153 @cindex underlining text
 154
 155 Underline @var{arg}.  Looks at @code{thickness} to determine line
 156 thickness and y offset."
 157   (let* ((thick (*
 158               (ly:output-def-lookup layout 'line-thickness)
 159               (chain-assoc-get 'thickness props 1)))
 160          (markup (interpret-markup layout props arg))
 161          (x1 (car (ly:stencil-extent markup X)))
 162          (x2 (cdr (ly:stencil-extent markup X)))
 163          (y (* thick -2))
 164          (line (ly:make-stencil
 165                 `(draw-line ,thick ,x1 ,y ,x2 ,y)
 166                 (cons (min x1 0) (max x2 0))
 167                 (cons thick thick))))
 168          (ly:stencil-add markup line)))
 169
 170 (define-builtin-markup-command (box layout props arg) (markup?)
 171   "
 172 @cindex enclosing text within a box
 173
 174 Draw a box round @var{arg}.  Looks at @code{thickness},
 175 @code{box-padding} and @code{font-size} properties to determine line
 176 thickness and padding around the markup."
 177   (let* ((th (*
 178               (ly:output-def-lookup layout 'line-thickness)
 179               (chain-assoc-get 'thickness props 1)))
 180          (size (chain-assoc-get 'font-size props 0))
 181          (pad (* (magstep size)
 182                  (chain-assoc-get 'box-padding props 0.2)))
 183          (m (interpret-markup layout props arg)))
 184     (box-stencil m th pad)))
 185
 186 (define-builtin-markup-command (filled-box layout props xext yext blot)
 187   (number-pair? number-pair? number?)
 188   "
 189 @cindex drawing solid boxes within text
 190 @cindex drawing boxes with rounded corners
 191
 192 Draw a box with rounded corners of dimensions @var{xext} and
 193 @var{yext}.  For example,
 194 @verbatim
 195 \\filled-box #'(-.3 . 1.8) #'(-.3 . 1.8) #0
 196 @end verbatim
 197 creates a box extending horizontally from -0.3 to 1.8 and
 198 vertically from -0.3 up to 1.8, with corners formed from a
 199 circle of diameter@tie{}0 (i.e. sharp corners)."
 200   (ly:round-filled-box
 201    xext yext blot))
 202
 203 (define-builtin-markup-command (rounded-box layout props arg) (markup?)
 204   "@cindex enclosing text in a bow with rounded corners
 205    @cindex drawing boxes with rounded corners around text
 206 Draw a box with rounded corners around @var{arg}.  Looks at @code{thickness},
 207 @code{box-padding} and @code{font-size} properties to determine line
 208 thickness and padding around the markup; the @code{corner-radius} property
 209 makes possible to define another shape for the corners (default is 1).
 210
 211 @lilypond[quote,verbatim,fragment,relative=2]
 212 c^\\markup{ \\rounded-box Overtura }
 213 c,8. c16 c4 r
 214 @end lilypond"
 215   (let* ((th (*
 216               (ly:output-def-lookup layout 'line-thickness)
 217               (chain-assoc-get 'thickness props 1)))
 218          (rad (chain-assoc-get 'corner-radius props 1))
 219          (size (chain-assoc-get 'font-size props 0))
 220          (pad (* (magstep size)
 221                  (chain-assoc-get 'box-padding props 0.5)))
 222          (m (interpret-markup layout props arg)))
 223     (ly:stencil-add (rounded-box-stencil m th pad rad)
 224     m)))
 225
 226 (define-builtin-markup-command (rotate layout props ang arg) (number? markup?)
 227   "
 228 @cindex rotating text
 229
 230 Rotate object with @var{ang} degrees around its center."
 231   (let* ((stil (interpret-markup layout props arg)))
 232     (ly:stencil-rotate stil ang 0 0)))
 233
 234 (define-builtin-markup-command (whiteout layout props arg) (markup?)
 235   "
 236 @cindex adding a white background to text
 237
 238 Provide a white background for @var{arg}."
 239   (stencil-whiteout (interpret-markup layout props arg)))
 240
 241 (define-builtin-markup-command (pad-markup layout props padding arg) (number? markup?)
 242   "
 243 @cindex padding text
 244 @cindex putting space around text
 245
 246 Add space around a markup object."
 247   (let*
 248       ((stil (interpret-markup layout props arg))
 249        (xext (ly:stencil-extent stil X))
 250        (yext (ly:stencil-extent stil Y)))
 251
 252     (ly:make-stencil
 253      (ly:stencil-expr stil)
 254      (interval-widen xext padding)
 255      (interval-widen yext padding))))
 256
 257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 258 ;; space
 259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 260
 261 (define-builtin-markup-command (strut layout props) ()
 262   "
 263 @cindex creating vertical spaces in text
 264
 265 Create a box of the same height as the space in the current font."
 266   (let ((m (ly:text-interface::interpret-markup layout props " ")))
 267     (ly:make-stencil (ly:stencil-expr m)
 268                      '(0 . 0)
 269                      (ly:stencil-extent m X)
 270                      )))
 271
 272 ;; todo: fix negative space
 273 (define-builtin-markup-command (hspace layout props amount) (number?)
 274   "
 275 @cindex creating horizontal spaces in text
 276
 277 This produces a invisible object taking horizontal space.  For example,
 278
 279 @example
 280 \\markup @{ A \\hspace #2.0 B @}
 281 @end example
 282
 283 @noindent
 284 puts extra space between A and@tie{}B, on top of the space that is
 285 normally inserted before elements on a line."
 286   (if (> amount 0)
 287       (ly:make-stencil "" (cons 0 amount) '(-1 . 1))
 288       (ly:make-stencil "" (cons amount amount) '(-1 . 1))))
 289
 290
 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292 ;; importing graphics.
 293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 294
 295 (define-builtin-markup-command (stencil layout props stil) (ly:stencil?)
 296   "
 297 @cindex importing stencils into text
 298
 299 Use a stencil as markup."
 300   stil)
 301
 302 (define bbox-regexp
 303   (make-regexp "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))
 304
 305 (define (get-postscript-bbox string)
 306   "Extract the bbox from STRING, or return #f if not present."
 307   (let*
 308       ((match (regexp-exec bbox-regexp string)))
 309
 310     (if match
 311         (map (lambda (x)
 312                (string->number (match:substring match x)))
 313              (cdr (iota 5)))
 314
 315         #f)))
 316
 317 (define-builtin-markup-command (epsfile layout props axis size file-name) (number? number? string?)
 318   "
 319 @cindex inlining an Encapsulated PostScript image
 320
 321 Inline an EPS image.  The image is scaled along @var{axis} to
 322 @var{size}."
 323   (if (ly:get-option 'safe)
 324       (interpret-markup layout props "not allowed in safe")
 325       (eps-file->stencil axis size file-name)
 326       ))
 327
 328 (define-builtin-markup-command (postscript layout props str) (string?)
 329   "
 330 @cindex inserting PostScript directly into text
 331
 332 This inserts @var{str} directly into the output as a PostScript
 333 command string.  Due to technicalities of the output backends,
 334 different scales should be used for the @TeX{} and PostScript backend,
 335 selected with @code{-f}.
 336
 337 For the @TeX{} backend, the following string prints a rotated text
 338
 339 @example
 340 0 0 moveto /ecrm10 findfont
 341 1.75 scalefont setfont 90 rotate (hello) show
 342 @end example
 343
 344 @noindent
 345 The magical constant 1.75 scales from LilyPond units (staff spaces) to
 346 @TeX{} dimensions.
 347
 348 For the postscript backend, use the following
 349
 350 @example
 351 gsave /ecrm10 findfont
 352  10.0 output-scale div
 353  scalefont setfont 90 rotate (hello) show grestore
 354 @end example"
 355   ;; FIXME
 356   (ly:make-stencil
 357    (list 'embedded-ps
 358          (format "
 359 gsave currentpoint translate
 360 0.1 setlinewidth
 361  ~a
 362 grestore
 363 "
 364                  str))
 365    '(0 . 0) '(0 . 0)))
 366
 367 (define-builtin-markup-command (score layout props score) (ly:score?)
 368   "
 369 @cindex inserting music into text
 370
 371 Inline an image of music."
 372   (let* ((output (ly:score-embedded-format score layout)))
 373
 374     (if (ly:music-output? output)
 375         (paper-system-stencil
 376          (vector-ref (ly:paper-score-paper-systems output) 0))
 377         (begin
 378           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
 379           empty-stencil))))
 380
 381 (define-builtin-markup-command (null layout props) ()
 382   "
 383 @cindex creating empty text objects
 384
 385 An empty markup with extents of a single point."
 386   point-stencil)
 387
 388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 389 ;; basic formatting.
 390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 391
 392 (define-builtin-markup-command (simple layout props str) (string?)
 393   "
 394 @cindex simple text strings
 395
 396 A simple text string; @code{\\markup @{ foo @}} is equivalent with
 397 @code{\\markup @{ \\simple #\"foo\" @}}."
 398   (interpret-markup layout props str))
 399
 400 (define-builtin-markup-command (tied-lyric layout props str) (string?)
 401   "
 402 @cindex simple text strings with tie characters
 403
 404 Like simple-markup, but use tie characters for @q{~} tilde symbols."
 405   (if (string-contains str "~")
 406       (let*
 407           ((parts (string-split str #\~))
 408            (tie-str (ly:wide-char->utf-8 #x203f))
 409            (joined  (list-join parts tie-str))
 410            (join-stencil (interpret-markup layout props tie-str))
 411            )
 412
 413         (interpret-markup layout
 414                           (prepend-alist-chain
 415                            'word-space
 416                            (/ (interval-length (ly:stencil-extent join-stencil X)) -3.5)
 417                            props)
 418                           (make-line-markup joined)))
 419                            ;(map (lambda (s) (interpret-markup layout props s)) parts))
 420       (interpret-markup layout props str)))
 421
 422 (define-public empty-markup
 423   (make-simple-markup ""))
 424
 425 ;; helper for justifying lines.
 426 (define (get-fill-space word-count line-width text-widths)
 427   "Calculate the necessary paddings between each two adjacent texts.
 428         The lengths of all texts are stored in @var{text-widths}.
 429         The normal formula for the padding between texts a and b is:
 430         padding = line-width/(word-count - 1) - (length(a) + length(b))/2
 431         The first and last padding have to be calculated specially using the
 432         whole length of the first or last text.
 433         Return a list of paddings."
 434   (cond
 435    ((null? text-widths) '())
 436
 437    ;; special case first padding
 438    ((= (length text-widths) word-count)
 439     (cons
 440      (- (- (/ line-width (1- word-count)) (car text-widths))
 441         (/ (car (cdr text-widths)) 2))
 442      (get-fill-space word-count line-width (cdr text-widths))))
 443    ;; special case last padding
 444    ((= (length text-widths) 2)
 445     (list (- (/ line-width (1- word-count))
 446              (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
 447    (else
 448     (cons
 449      (- (/ line-width (1- word-count))
 450         (/ (+ (car text-widths) (car (cdr text-widths))) 2))
 451      (get-fill-space word-count line-width (cdr text-widths))))))
 452
 453 (define-builtin-markup-command (fill-line layout props markups)
 454   (markup-list?)
 455   "Put @var{markups} in a horizontal line of width @var{line-width}.
 456 The markups are spaced or flushed to fill the entire line.
 457 If there are no arguments, return an empty stencil."
 458
 459   (let* ((orig-stencils (interpret-markup-list layout props markups))
 460          (stencils
 461           (map (lambda (stc)
 462                  (if (ly:stencil-empty? stc)
 463                      point-stencil
 464                      stc)) orig-stencils))
 465          (text-widths
 466           (map (lambda (stc)
 467                  (if (ly:stencil-empty? stc)
 468                      0.0
 469                      (interval-length (ly:stencil-extent stc X))))
 470                stencils))
 471          (text-width (apply + text-widths))
 472          (text-dir (chain-assoc-get 'text-direction props RIGHT))
 473          (word-count (length stencils))
 474          (word-space (chain-assoc-get 'word-space props 1))
 475          (prop-line-width (chain-assoc-get 'line-width props #f))
 476          (line-width (if prop-line-width prop-line-width
 477                          (ly:output-def-lookup layout 'line-width)))
 478          (fill-space
 479                 (cond
 480                         ((= word-count 1)
 481                                 (list
 482                                         (/ (- line-width text-width) 2)
 483                                         (/ (- line-width text-width) 2)))
 484                         ((= word-count 2)
 485                                 (list
 486                                         (- line-width text-width)))
 487                         (else
 488                                 (get-fill-space word-count line-width text-widths))))
 489          (fill-space-normal
 490           (map (lambda (x)
 491                  (if (< x word-space)
 492                      word-space
 493                      x))
 494                fill-space))
 495
 496          (line-stencils (if (= word-count 1)
 497                             (list
 498                              point-stencil
 499                              (car stencils)
 500                              point-stencil)
 501                             stencils)))
 502
 503     (if (= text-dir LEFT)
 504         (set! line-stencils (reverse line-stencils)))
 505
 506     (if (null? (remove ly:stencil-empty? orig-stencils))
 507         empty-stencil
 508         (stack-stencils-padding-list X
 509                                      RIGHT fill-space-normal line-stencils))))
 510
 511 (define-builtin-markup-command (line layout props args) (markup-list?)
 512   "Put @var{args} in a horizontal line.  The property @code{word-space}
 513 determines the space between each markup in @var{args}."
 514   (let*
 515       ((stencils (interpret-markup-list layout props args))
 516        (space    (chain-assoc-get 'word-space props))
 517        (text-dir (chain-assoc-get 'text-direction props RIGHT))
 518        )
 519
 520     (if (= text-dir LEFT)
 521         (set! stencils (reverse stencils)))
 522
 523     (stack-stencil-line
 524      space
 525      (remove ly:stencil-empty? stencils))))
 526
 527 (define-builtin-markup-command (concat layout props args) (markup-list?)
 528   "
 529 @cindex concatenating text
 530 @cindex ligatures in text
 531
 532 Concatenate @var{args} in a horizontal line, without spaces inbetween.
 533 Strings and simple markups are concatenated on the input level, allowing
 534 ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
 535 equivalent to @code{\"fi\"}."
 536   (define (concat-string-args arg-list)
 537     (fold-right (lambda (arg result-list)
 538                   (let ((result (if (pair? result-list)
 539                                     (car result-list)
 540                                   '())))
 541                     (if (and (pair? arg) (eqv? (car arg) simple-markup))
 542                       (set! arg (cadr arg)))
 543                     (if (and (string? result) (string? arg))
 544                         (cons (string-append arg result) (cdr result-list))
 545                       (cons arg result-list))))
 546                 '()
 547                 arg-list))
 548
 549   (interpret-markup layout
 550                     (prepend-alist-chain 'word-space 0 props)
 551                     (make-line-markup (if (markup-command-list? args)
 552                                           args
 553                                           (concat-string-args args)))))
 554
 555 (define (wordwrap-stencils stencils
 556                            justify base-space line-width text-dir)
 557   "Perform simple wordwrap, return stencil of each line."
 558   (define space (if justify
 559
 560                     ;; justify only stretches lines.
 561                     (* 0.7 base-space)
 562                     base-space))
 563
 564   (define (take-list width space stencils
 565                      accumulator accumulated-width)
 566     "Return (head-list . tail) pair, with head-list fitting into width"
 567     (if (null? stencils)
 568         (cons accumulator stencils)
 569         (let*
 570             ((first (car stencils))
 571              (first-wid (cdr (ly:stencil-extent (car stencils) X)))
 572              (newwid (+ space first-wid accumulated-width))
 573              )
 574
 575           (if
 576            (or (null? accumulator)
 577                (< newwid width))
 578
 579            (take-list width space
 580                       (cdr stencils)
 581                       (cons first accumulator)
 582                       newwid)
 583              (cons accumulator stencils))
 584            )))
 585
 586     (let loop
 587         ((lines '())
 588          (todo stencils))
 589
 590       (let*
 591           ((line-break (take-list line-width space todo
 592                                  '() 0.0))
 593            (line-stencils (car line-break))
 594            (space-left (- line-width (apply + (map (lambda (x) (cdr (ly:stencil-extent x X)))
 595                                               line-stencils))))
 596
 597            (line-word-space (cond
 598                              ((not justify) space)
 599
 600                              ;; don't stretch last line of paragraph.
 601                              ;; hmmm . bug - will overstretch the last line in some case.
 602                              ((null? (cdr line-break))
 603                               base-space)
 604                              ((null? line-stencils) 0.0)
 605                              ((null? (cdr line-stencils)) 0.0)
 606                              (else (/ space-left (1- (length line-stencils))))))
 607
 608            (line (stack-stencil-line
 609                   line-word-space
 610                   (if (= text-dir RIGHT)
 611                       (reverse line-stencils)
 612                       line-stencils))))
 613
 614         (if (pair? (cdr line-break))
 615             (loop (cons line lines)
 616                   (cdr line-break))
 617
 618             (begin
 619               (if (= text-dir LEFT)
 620                   (set! line
 621                         (ly:stencil-translate-axis line
 622                                                    (- line-width (interval-end (ly:stencil-extent line X)))
 623                                                    X)))
 624               (reverse (cons line lines))
 625
 626             )))
 627
 628       ))
 629
 630 (define (wordwrap-markups layout props args justify)
 631   (let*
 632       ((prop-line-width (chain-assoc-get 'line-width props #f))
 633        (line-width (if prop-line-width prop-line-width
 634                        (ly:output-def-lookup layout 'line-width)))
 635        (word-space (chain-assoc-get 'word-space props))
 636        (text-dir (chain-assoc-get 'text-direction props RIGHT)))
 637     (wordwrap-stencils (remove ly:stencil-empty?
 638                                (interpret-markup-list layout props args))
 639                        justify word-space line-width
 640                        text-dir)))
 641
 642 (define-builtin-markup-command (justify layout props args) (markup-list?)
 643   "
 644 @cindex justifying text
 645
 646 Like wordwrap, but with lines stretched to justify the margins.
 647 Use @code{\\override #'(line-width . @var{X})} to set the line width;
 648 @var{X}@tie{}is the number of staff spaces."
 649   (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
 650                (wordwrap-markups layout props args #t)))
 651
 652 (define-builtin-markup-command (wordwrap layout props args) (markup-list?)
 653   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
 654 the line width, where @var{X} is the number of staff spaces."
 655   (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
 656                (wordwrap-markups layout props args #f)))
 657
 658 (define (wordwrap-string layout props justify arg)
 659   (let*
 660       ((baseline-skip (chain-assoc-get 'baseline-skip props))
 661        (line-width (chain-assoc-get 'line-width props))
 662        (word-space (chain-assoc-get 'word-space props))
 663
 664        (para-strings (regexp-split
 665                       (string-regexp-substitute "\r" "\n"
 666                                                 (string-regexp-substitute "\r\n" "\n" arg))
 667                       "\n[ \t\n]*\n[ \t\n]*"))
 668
 669        (text-dir (chain-assoc-get 'text-direction props RIGHT))
 670        (list-para-words (map (lambda (str)
 671                                (regexp-split str "[ \t\n]+"))
 672                              para-strings))
 673        (para-lines (map (lambda (words)
 674                           (let*
 675                               ((stencils
 676                                 (remove
 677                                  ly:stencil-empty? (map
 678                                       (lambda (x)
 679                                         (interpret-markup layout props x))
 680                                       words)))
 681                                (lines (wordwrap-stencils stencils
 682                                                          justify word-space
 683                                                          line-width text-dir
 684                                                          )))
 685
 686                             lines))
 687
 688                         list-para-words)))
 689
 690     (stack-lines DOWN 0.0 baseline-skip (apply append para-lines))))
 691
 692 (define-builtin-markup-command (wordwrap-string layout props arg) (string?)
 693   "Wordwrap a string.  Paragraphs may be separated with double newlines."
 694   (wordwrap-string layout props  #f arg))
 695
 696 (define-builtin-markup-command (justify-string layout props arg) (string?)
 697   "Justify a string.  Paragraphs may be separated with double newlines"
 698   (wordwrap-string layout props #t arg))
 699
 700 (define-builtin-markup-command (wordwrap-field layout props symbol) (symbol?)
 701   "Wordwrap the data which has been assigned to @var{symbol}."
 702   (let* ((m (chain-assoc-get symbol props)))
 703     (if (string? m)
 704      (interpret-markup layout props
 705       (list wordwrap-string-markup m))
 706      empty-stencil)))
 707
 708 (define-builtin-markup-command (justify-field layout props symbol) (symbol?)
 709   "Justify the data which has been assigned to @var{symbol}."
 710   (let* ((m (chain-assoc-get symbol props)))
 711     (if (string? m)
 712      (interpret-markup layout props
 713       (list justify-string-markup m))
 714      empty-stencil)))
 715
 716 (define-builtin-markup-command (combine layout props m1 m2) (markup? markup?)
 717   "
 718 @cindex merging text
 719
 720 Print two markups on top of each other."
 721   (let* ((s1 (interpret-markup layout props m1))
 722          (s2 (interpret-markup layout props m2)))
 723     (ly:stencil-add s1 s2)))
 724
 725 ;;
 726 ;; TODO: should extract baseline-skip from each argument somehow..
 727 ;;
 728 (define-builtin-markup-command (column layout props args) (markup-list?)
 729   "
 730 @cindex stacking text in a column
 731
 732 Stack the markups in @var{args} vertically.  The property
 733 @code{baseline-skip} determines the space between each markup in @var{args}."
 734   (let*
 735       ((arg-stencils (interpret-markup-list layout props args))
 736        (skip (chain-assoc-get 'baseline-skip props)))
 737
 738     (stack-lines
 739      -1 0.0 skip
 740      (remove ly:stencil-empty? arg-stencils))))
 741
 742 (define-builtin-markup-command (dir-column layout props args) (markup-list?)
 743   "
 744 @cindex changing direction of text columns
 745
 746 Make a column of args, going up or down, depending on the setting
 747 of the @code{#'direction} layout property."
 748   (let* ((dir (chain-assoc-get 'direction props)))
 749     (stack-lines
 750      (if (number? dir) dir -1)
 751      0.0
 752      (chain-assoc-get 'baseline-skip props)
 753      (interpret-markup-list layout props args))))
 754
 755 (define-builtin-markup-command (center-align layout props args) (markup-list?)
 756   "
 757 @cindex centering a column of text
 758
 759 Put @code{args} in a centered column."
 760   (let* ((mols (interpret-markup-list layout props args))
 761          (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
 762
 763     (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))
 764
 765 (define-builtin-markup-command (vcenter layout props arg) (markup?)
 766   "
 767 @cindex vertically centering text
 768
 769 Align @code{arg} to its Y@tie{}center."
 770   (let* ((mol (interpret-markup layout props arg)))
 771     (ly:stencil-aligned-to mol Y CENTER)))
 772
 773 (define-builtin-markup-command (hcenter layout props arg) (markup?)
 774   "
 775 @cindex horizontally centering text
 776
 777 Align @code{arg} to its X@tie{}center."
 778   (let* ((mol (interpret-markup layout props arg)))
 779     (ly:stencil-aligned-to mol X CENTER)))
 780
 781 (define-builtin-markup-command (right-align layout props arg) (markup?)
 782   "
 783 @cindex right aligning text
 784
 785 Align @var{arg} on its right edge."
 786   (let* ((m (interpret-markup layout props arg)))
 787     (ly:stencil-aligned-to m X RIGHT)))
 788
 789 (define-builtin-markup-command (left-align layout props arg) (markup?)
 790   "
 791 @cindex left aligning text
 792
 793 Align @var{arg} on its left edge."
 794   (let* ((m (interpret-markup layout props arg)))
 795     (ly:stencil-aligned-to m X LEFT)))
 796
 797 (define-builtin-markup-command (general-align layout props axis dir arg)  (integer? number? markup?)
 798   "
 799 @cindex controlling general text alignment
 800
 801 Align @var{arg} in @var{axis} direction to the @var{dir} side."
 802   (let* ((m (interpret-markup layout props arg)))
 803     (ly:stencil-aligned-to m axis dir)))
 804
 805 (define-builtin-markup-command (halign layout props dir arg) (number? markup?)
 806   "
 807 @cindex setting horizontal text alignment
 808
 809 Set horizontal alignment.  If @var{dir} is @code{-1}, then it is
 810 left-aligned, while @code{+1} is right.  Values inbetween interpolate
 811 alignment accordingly."
 812   (let* ((m (interpret-markup layout props arg)))
 813     (ly:stencil-aligned-to m X dir)))
 814
 815 (define-builtin-markup-command (with-dimensions layout props x y arg) (number-pair? number-pair? markup?)
 816   "
 817 @cindex setting extent of text objects
 818
 819 Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}."
 820   (let* ((m (interpret-markup layout props arg)))
 821     (ly:make-stencil (ly:stencil-expr m) x y)))
 822
 823 (define-builtin-markup-command (pad-around layout props amount arg) (number? markup?)
 824   "Add padding @var{amount} all around @var{arg}."
 825   (let*
 826       ((m (interpret-markup layout props arg))
 827        (x (ly:stencil-extent m X))
 828        (y (ly:stencil-extent m Y)))
 829
 830
 831     (ly:make-stencil (ly:stencil-expr m)
 832                      (interval-widen x amount)
 833                      (interval-widen y amount))
 834    ))
 835
 836 (define-builtin-markup-command (pad-x layout props amount arg) (number? markup?)
 837   "
 838 @cindex padding text horizontally
 839
 840 Add padding @var{amount} around @var{arg} in the X@tie{}direction."
 841   (let*
 842       ((m (interpret-markup layout props arg))
 843        (x (ly:stencil-extent m X))
 844        (y (ly:stencil-extent m Y)))
 845
 846
 847     (ly:make-stencil (ly:stencil-expr m)
 848                      (interval-widen x amount)
 849                      y)
 850    ))
 851
 852 (define-builtin-markup-command (put-adjacent layout props arg1 axis dir arg2) (markup? integer? ly:dir?  markup?)
 853   "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}."
 854   (let* ((m1 (interpret-markup layout props arg1))
 855          (m2 (interpret-markup layout props arg2)))
 856
 857     (ly:stencil-combine-at-edge m1 axis dir m2 0.0)
 858   ))
 859
 860 (define-builtin-markup-command (transparent layout props arg) (markup?)
 861   "Make the argument transparent."
 862   (let*
 863       ((m (interpret-markup layout props arg))
 864        (x (ly:stencil-extent m X))
 865        (y (ly:stencil-extent m Y)))
 866
 867     (ly:make-stencil ""
 868                      x y)))
 869
 870 (define-builtin-markup-command (pad-to-box layout props x-ext y-ext arg)
 871   (number-pair? number-pair? markup?)
 872   "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space."
 873
 874   (let*
 875       ((m (interpret-markup layout props arg))
 876        (x (ly:stencil-extent m X))
 877        (y (ly:stencil-extent m Y)))
 878
 879     (ly:make-stencil (ly:stencil-expr m)
 880                      (interval-union x-ext x)
 881                      (interval-union y-ext y))))
 882
 883
 884 (define-builtin-markup-command (hcenter-in layout props length arg)
 885   (number? markup?)
 886   "Center @var{arg} horizontally within a box of extending
 887 @var{length}/2 to the left and right."
 888
 889   (interpret-markup layout props
 890                     (make-pad-to-box-markup
 891                      (cons (/ length -2) (/ length 2))
 892                      '(0 . 0)
 893                      (make-hcenter-markup arg))))
 894
 895 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 896 ;; property
 897 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 898
 899 (define-builtin-markup-command (fromproperty layout props symbol) (symbol?)
 900   "Read the @var{symbol} from property settings, and produce a stencil
 901 from the markup contained within.  If @var{symbol} is not defined, it
 902 returns an empty markup."
 903   (let* ((m (chain-assoc-get symbol props)))
 904     (if (markup? m)
 905         (interpret-markup layout props m)
 906         empty-stencil)))
 907
 908 (define-builtin-markup-command (on-the-fly layout props procedure arg) (symbol? markup?)
 909   "Apply the @var{procedure} markup command to @var{arg}.
 910 @var{procedure} should take a single argument."
 911   (let* ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
 912     (set-object-property! anonymous-with-signature
 913                           'markup-signature
 914                           (list markup?))
 915     (interpret-markup layout props (list anonymous-with-signature arg))))
 916
 917 (define-builtin-markup-command (override layout props new-prop arg) (pair? markup?)
 918   "
 919 @cindex overriding properties within text markup
 920
 921 Add the first argument in to the property list.  Properties may be
 922 any sort of property supported by @internalsref{font-interface} and
 923 @internalsref{text-interface}, for example
 924
 925 @example
 926 \\override #'(font-family . married) \"bla\"
 927 @end example"
 928   (interpret-markup layout (cons (list new-prop) props) arg))
 929
 930 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 931 ;; files
 932 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 933
 934 (define-builtin-markup-command (verbatim-file layout props name) (string?)
 935   "Read the contents of a file, and include it verbatim."
 936
 937   (interpret-markup
 938    layout props
 939    (if  (ly:get-option 'safe)
 940         "verbatim-file disabled in safe mode"
 941         (let*
 942             ((str (ly:gulp-file name))
 943              (lines (string-split str #\nl)))
 944
 945           (make-typewriter-markup
 946            (make-column-markup lines)))
 947         )))
 948
 949 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 950 ;; fonts.
 951 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 952
 953 (define-builtin-markup-command (bigger layout props arg) (markup?)
 954   "Increase the font size relative to current setting."
 955   (interpret-markup layout props
 956    `(,fontsize-markup 1 ,arg)))
 957
 958 (define-builtin-markup-command (smaller layout props arg) (markup?)
 959   "Decrease the font size relative to current setting."
 960   (interpret-markup layout props
 961    `(,fontsize-markup -1 ,arg)))
 962
 963 (define-builtin-markup-command larger (markup?) bigger-markup)
 964
 965 (define-builtin-markup-command (finger layout props arg) (markup?)
 966   "Set the argument as small numbers."
 967   (interpret-markup layout
 968                     (cons '((font-size . -5) (font-encoding . fetaNumber)) props)
 969                     arg))
 970
 971 (define-builtin-markup-command (fontsize layout props increment arg) (number? markup?)
 972   "Add @var{increment} to the font-size.  Adjust baseline skip accordingly."
 973
 974   (let* ((fs (chain-assoc-get 'font-size props 0))
 975          (bs (chain-assoc-get 'baseline-skip props 2))
 976          (entries (list
 977                    (cons 'baseline-skip (* bs (magstep increment)))
 978                    (cons 'font-size (+ fs increment )))))
 979
 980     (interpret-markup layout (cons entries props) arg)))
 981
 982 (define-builtin-markup-command (magnify layout props sz arg) (number? markup?)
 983   "
 984 @cindex magnifying text
 985
 986 Set the font magnification for its argument.  In the following
 987 example, the middle@tie{}A is 10% larger:
 988
 989 @example
 990 A \\magnify #1.1 @{ A @} A
 991 @end example
 992
 993 Note: Magnification only works if a font name is explicitly selected.
 994 Use @code{\\fontsize} otherwise."
 995   (interpret-markup
 996    layout
 997    (prepend-alist-chain 'font-size (magnification->font-size sz) props)
 998    arg))
 999
1000 (define-builtin-markup-command (bold layout props arg) (markup?)
1001   "Switch to bold font-series."
1002   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
1003
1004 (define-builtin-markup-command (sans layout props arg) (markup?)
1005   "Switch to the sans serif family."
1006   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
1007
1008 (define-builtin-markup-command (number layout props arg) (markup?)
1009   "Set font family to @code{number}, which yields the font used for
1010 time signatures and fingerings.  This font only contains numbers and
1011 some punctuation.  It doesn't have any letters."
1012   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaNumber props) arg))
1013
1014 (define-builtin-markup-command (roman layout props arg) (markup?)
1015   "Set font family to @code{roman}."
1016   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
1017
1018 (define-builtin-markup-command (huge layout props arg) (markup?)
1019   "Set font size to +2."
1020   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
1021
1022 (define-builtin-markup-command (large layout props arg) (markup?)
1023   "Set font size to +1."
1024   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
1025
1026 (define-builtin-markup-command (normalsize layout props arg) (markup?)
1027   "Set font size to default."
1028   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
1029
1030 (define-builtin-markup-command (small layout props arg) (markup?)
1031   "Set font size to -1."
1032   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
1033
1034 (define-builtin-markup-command (tiny layout props arg) (markup?)
1035   "Set font size to -2."
1036   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
1037
1038 (define-builtin-markup-command (teeny layout props arg) (markup?)
1039   "Set font size to -3."
1040   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
1041
1042 (define-builtin-markup-command (fontCaps layout props arg) (markup?)
1043   "Set @code{font-shape} to @code{caps}."
1044   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
1045
1046 ;; Poor man's caps
1047 (define-builtin-markup-command (smallCaps layout props text) (markup?)
1048   "Turn @code{text}, which should be a string, to small caps.
1049 @example
1050 \\markup \\smallCaps \"Text between double quotes\"
1051 @end example
1052
1053 Note: @code{\\smallCaps} does not support accented characters."
1054   (define (char-list->markup chars lower)
1055     (let ((final-string (string-upcase (reverse-list->string chars))))
1056       (if lower
1057           (markup #:fontsize -2 final-string)
1058           final-string)))
1059   (define (make-small-caps rest-chars currents current-is-lower prev-result)
1060     (if (null? rest-chars)
1061         (make-concat-markup
1062           (reverse! (cons (char-list->markup currents current-is-lower)
1063                           prev-result)))
1064         (let* ((ch (car rest-chars))
1065                (is-lower (char-lower-case? ch)))
1066           (if (or (and current-is-lower is-lower)
1067                   (and (not current-is-lower) (not is-lower)))
1068               (make-small-caps (cdr rest-chars)
1069                                (cons ch currents)
1070                                is-lower
1071                                prev-result)
1072               (make-small-caps (cdr rest-chars)
1073                                (list ch)
1074                                is-lower
1075                                (if (null? currents)
1076                                    prev-result
1077                                    (cons (char-list->markup
1078                                             currents current-is-lower)
1079                                          prev-result)))))))
1080   (interpret-markup layout props
1081     (if (string? text)
1082         (make-small-caps (string->list text) (list) #f (list))
1083         text)))
1084
1085 (define-builtin-markup-command (caps layout props arg) (markup?)
1086   "Emit @var{arg} as small caps."
1087   (interpret-markup layout props (make-smallCaps-markup arg)))
1088
1089 (define-builtin-markup-command (dynamic layout props arg) (markup?)
1090   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
1091 @b{z}, @b{p}, and @b{r}.  When producing phrases, like
1092 @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be
1093 done in a different font.  The recommended font for this is bold and italic."
1094   (interpret-markup
1095    layout (prepend-alist-chain 'font-encoding 'fetaDynamic props) arg))
1096
1097 (define-builtin-markup-command (text layout props arg) (markup?)
1098   "Use a text font instead of music symbol or music alphabet font."
1099
1100   ;; ugh - latin1
1101   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
1102                     arg))
1103
1104 (define-builtin-markup-command (italic layout props arg) (markup?)
1105   "Use italic @code{font-shape} for @var{arg}."
1106   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
1107
1108 (define-builtin-markup-command (typewriter layout props arg) (markup?)
1109   "Use @code{font-family} typewriter for @var{arg}."
1110   (interpret-markup
1111    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
1112
1113 (define-builtin-markup-command (upright layout props arg) (markup?)
1114   "Set font shape to @code{upright}.  This is the opposite of @code{italic}."
1115   (interpret-markup
1116    layout (prepend-alist-chain 'font-shape 'upright props) arg))
1117
1118 (define-builtin-markup-command (medium layout props arg) (markup?)
1119   "Switch to medium font series (in contrast to bold)."
1120   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
1121                     arg))
1122
1123 (define-builtin-markup-command (normal-text layout props arg) (markup?)
1124   "Set all font related properties (except the size) to get the default
1125 normal text font, no matter what font was used earlier."
1126   ;; ugh - latin1
1127   (interpret-markup layout
1128                     (cons '((font-family . roman) (font-shape . upright)
1129                             (font-series . medium) (font-encoding . latin1))
1130                           props)
1131                     arg))
1132
1133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1134 ;; symbols.
1135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1136
1137 (define-builtin-markup-command (doublesharp layout props) ()
1138   "Draw a double sharp symbol.
1139 @c
1140 @lilypond[verbatim,quote]
1141 \\markup { \\doublesharp }
1142 @end lilypond"
1143   (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist ""))))
1144
1145 (define-builtin-markup-command (sesquisharp layout props) ()
1146   "Draw a 3/2 sharp symbol.
1147 @c
1148 @lilypond[verbatim,quote]
1149 \\markup { \\sesquisharp }
1150 @end lilypond"
1151   (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist ""))))
1152
1153 (define-builtin-markup-command (sharp layout props) ()
1154   "Draw a sharp symbol.
1155 @c
1156 @lilypond[verbatim,quote]
1157 \\markup { \\sharp }
1158 @end lilypond"
1159   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist ""))))
1160
1161 (define-builtin-markup-command (semisharp layout props) ()
1162   "Draw a semi sharp symbol.
1163 @c
1164 @lilypond[verbatim,quote]
1165 \\markup { \\semisharp }
1166 @end lilypond"
1167   (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist ""))))
1168
1169 (define-builtin-markup-command (natural layout props) ()
1170   "Draw a natural symbol.
1171 @c
1172 @lilypond[verbatim,quote]
1173 \\markup { \\natural }
1174 @end lilypond"
1175   (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist ""))))
1176
1177 (define-builtin-markup-command (semiflat layout props) ()
1178   "Draw a semiflat symbol.
1179 @c
1180 @lilypond[verbatim,quote]
1181 \\markup { \\semiflat }
1182 @end lilypond"
1183   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist ""))))
1184
1185 (define-builtin-markup-command (flat layout props) ()
1186   "Draw a flat symbol.
1187 @c
1188 @lilypond[verbatim,quote]
1189 \\markup { \\flat }
1190 @end lilypond"
1191   (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist ""))))
1192
1193 (define-builtin-markup-command (sesquiflat layout props) ()
1194   "Draw a 3/2 flat symbol.
1195 @c
1196 @lilypond[verbatim,quote]
1197 \\markup { \\sesquiflat }
1198 @end lilypond"
1199   (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist ""))))
1200
1201 (define-builtin-markup-command (doubleflat layout props) ()
1202   "Draw a double flat symbol.
1203 @c
1204 @lilypond[verbatim,quote]
1205 \\markup { \\doubleflat }
1206 @end lilypond"
1207   (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist ""))))
1208
1209 (define-builtin-markup-command (with-color layout props color arg) (color? markup?)
1210   "
1211 @cindex coloring text
1212
1213 Draw @var{arg} in color specified by @var{color}."
1214   (let* ((stil (interpret-markup layout props arg)))
1215
1216     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
1217                      (ly:stencil-extent stil X)
1218                      (ly:stencil-extent stil Y))))
1219 \f
1220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1221 ;; glyphs
1222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1223
1224 (define-builtin-markup-command (arrow-head layout props axis direction filled)
1225   (integer? ly:dir? boolean?)
1226   "Produce an arrow head in specified direction and axis.
1227 Use the filled head if @var{filled} is specified."
1228   (let*
1229       ((name (format "arrowheads.~a.~a~a"
1230                      (if filled
1231                          "close"
1232                          "open")
1233                      axis
1234                      direction)))
1235     (ly:font-get-glyph
1236      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
1237                                      props))
1238      name)))
1239
1240 (define-builtin-markup-command (musicglyph layout props glyph-name) (string?)
1241   "@var{glyph-name} is converted to a musical symbol; for example,
1242 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
1243 the music font.  See @ruser{The Feta font} for a complete listing of
1244 the possible glyphs."
1245   (ly:font-get-glyph
1246    (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
1247                                    props))
1248    glyph-name))
1249
1250 (define-builtin-markup-command (lookup layout props glyph-name) (string?)
1251   "Lookup a glyph by name."
1252   (ly:font-get-glyph (ly:paper-get-font layout props)
1253                      glyph-name))
1254
1255 (define-builtin-markup-command (char layout props num) (integer?)
1256   "Produce a single character.  For example, @code{\\char #65} produces the
1257 letter @q{A}."
1258   (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num)))
1259
1260 (define number->mark-letter-vector (make-vector 25 #\A))
1261
1262 (do ((i 0 (1+ i))
1263      (j 0 (1+ j)))
1264     ((>= i 26))
1265   (if (= i (- (char->integer #\I) (char->integer #\A)))
1266       (set! i (1+ i)))
1267   (vector-set! number->mark-letter-vector j
1268                (integer->char (+ i (char->integer #\A)))))
1269
1270 (define number->mark-alphabet-vector (list->vector
1271   (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
1272
1273 (define (number->markletter-string vec n)
1274   "Double letters for big marks."
1275   (let* ((lst (vector-length vec)))
1276
1277     (if (>= n lst)
1278         (string-append (number->markletter-string vec (1- (quotient n lst)))
1279                        (number->markletter-string vec (remainder n lst)))
1280         (make-string 1 (vector-ref vec n)))))
1281
1282 (define-builtin-markup-command (markletter layout props num) (integer?)
1283   "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
1284 (skipping letter@tie{}I), and continue with double letters."
1285   (ly:text-interface::interpret-markup layout props
1286     (number->markletter-string number->mark-letter-vector num)))
1287
1288 (define-builtin-markup-command (markalphabet layout props num) (integer?)
1289    "Make a markup letter for @var{num}.  The letters start with A to@tie{}Z
1290 and continue with double letters."
1291    (ly:text-interface::interpret-markup layout props
1292      (number->markletter-string number->mark-alphabet-vector num)))
1293
1294 (define-builtin-markup-command (slashed-digit layout props num) (integer?)
1295   "
1296 @cindex slashed digits
1297
1298 A feta number, with slash.  This is for use in the context of
1299 figured bass notation."
1300   (let*
1301       ((mag (magstep (chain-assoc-get 'font-size props 0)))
1302        (thickness
1303         (* mag
1304            (ly:output-def-lookup layout 'line-thickness)
1305            (chain-assoc-get 'thickness props 1.6)))
1306        (dy (* mag 0.15))
1307        (number-stencil (interpret-markup layout
1308                                          (prepend-alist-chain 'font-encoding 'fetaNumber props)
1309                                          (number->string num)))
1310        (num-x (interval-widen (ly:stencil-extent number-stencil X)
1311                               (* mag 0.2)))
1312        (num-y (ly:stencil-extent number-stencil Y))
1313        (is-sane (and (interval-sane? num-x) (interval-sane? num-y)))
1314
1315        (slash-stencil
1316         (if is-sane
1317             (ly:make-stencil
1318              `(draw-line
1319                ,thickness
1320                ,(car num-x) ,(- (interval-center num-y) dy)
1321                ,(cdr num-x) ,(+ (interval-center num-y) dy))
1322              num-x num-y)
1323             #f)))
1324
1325     (set! slash-stencil
1326           (cond
1327            ((not (ly:stencil? slash-stencil)) #f)
1328            ((= num 5) (ly:stencil-translate slash-stencil
1329                                             ;;(cons (* mag -0.05) (* mag 0.42))
1330                                             (cons (* mag -0.00) (* mag -0.07))
1331
1332                                             ))
1333            ((= num 7) (ly:stencil-translate slash-stencil
1334                                             ;;(cons (* mag -0.05) (* mag 0.42))
1335                                             (cons (* mag -0.00) (* mag -0.15))
1336
1337                                             ))
1338
1339            (else slash-stencil)))
1340
1341     (if slash-stencil
1342         (set! number-stencil
1343               (ly:stencil-add number-stencil slash-stencil))
1344
1345         (ly:warning "invalid number for slashed digit ~a" num))
1346
1347     number-stencil))
1348 \f
1349 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1350 ;; the note command.
1351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1352
1353 ;; TODO: better syntax.
1354
1355 (define-builtin-markup-command (note-by-number layout props log dot-count dir) (number? number? number?)
1356   "
1357 @cindex notes within text by log and dot-count
1358
1359 Construct a note symbol, with stem.  By using fractional values for
1360 @var{dir}, you can obtain longer or shorter stems."
1361
1362   (define (get-glyph-name-candidates dir log style)
1363     (map (lambda (dir-name)
1364      (format "noteheads.~a~a~a" dir-name (min log 2)
1365              (if (and (symbol? style)
1366                       (not (equal? 'default style)))
1367                  (symbol->string style)
1368                  "")))
1369          (list (if (= dir UP) "u" "d")
1370                "s")))
1371
1372   (define (get-glyph-name font cands)
1373     (if (null? cands)
1374      ""
1375      (if (ly:stencil-empty? (ly:font-get-glyph font (car cands)))
1376          (get-glyph-name font (cdr cands))
1377          (car cands))))
1378
1379   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) props)))
1380          (size-factor (magstep (chain-assoc-get 'font-size props 0)))
1381          (style (chain-assoc-get 'style props '()))
1382          (stem-length (*  size-factor (max 3 (- log 1))))
1383          (head-glyph-name (get-glyph-name font (get-glyph-name-candidates (sign dir) log style)))
1384          (head-glyph (ly:font-get-glyph font head-glyph-name))
1385          (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
1386          (stem-thickness (* size-factor 0.13))
1387          (stemy (* dir stem-length))
1388          (attach-off (cons (interval-index
1389                             (ly:stencil-extent head-glyph X)
1390                             (* (sign dir) (car attach-indices)))
1391                            (* (sign dir)        ; fixme, this is inconsistent between X & Y.
1392                               (interval-index
1393                                (ly:stencil-extent head-glyph Y)
1394                                (cdr attach-indices)))))
1395          (stem-glyph (and (> log 0)
1396                           (ly:round-filled-box
1397                            (ordered-cons (car attach-off)
1398                                          (+ (car attach-off)  (* (- (sign dir)) stem-thickness)))
1399                            (cons (min stemy (cdr attach-off))
1400                                  (max stemy (cdr attach-off)))
1401                            (/ stem-thickness 3))))
1402
1403          (dot (ly:font-get-glyph font "dots.dot"))
1404          (dotwid (interval-length (ly:stencil-extent dot X)))
1405          (dots (and (> dot-count 0)
1406                     (apply ly:stencil-add
1407                            (map (lambda (x)
1408                                   (ly:stencil-translate-axis
1409                                    dot (* 2 x dotwid) X))
1410                                 (iota dot-count)))))
1411          (flaggl (and (> log 2)
1412                       (ly:stencil-translate
1413                        (ly:font-get-glyph font
1414                                           (string-append "flags."
1415                                                          (if (> dir 0) "u" "d")
1416                                                          (number->string log)))
1417                        (cons (+ (car attach-off) (/ stem-thickness 2)) stemy)))))
1418
1419     (if (and dots flaggl (> dir 0))
1420         (set! dots (ly:stencil-translate-axis dots 0.35 X)))
1421     (if flaggl
1422         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
1423     (if (ly:stencil? stem-glyph)
1424         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
1425         (set! stem-glyph head-glyph))
1426     (if (ly:stencil? dots)
1427         (set! stem-glyph
1428               (ly:stencil-add
1429                (ly:stencil-translate-axis
1430                 dots
1431                 (+ (cdr (ly:stencil-extent head-glyph X)) dotwid)
1432                 X)
1433                stem-glyph)))
1434     stem-glyph))
1435
1436 (define-public log2
1437   (let ((divisor (log 2)))
1438     (lambda (z) (inexact->exact (/ (log z) divisor)))))
1439
1440 (define (parse-simple-duration duration-string)
1441   "Parse the `duration-string', e.g. ''4..'' or ''breve.'', and return a (log dots) list."
1442   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string)))
1443     (if (and match (string=? duration-string (match:substring match 0)))
1444         (let ((len  (match:substring match 1))
1445               (dots (match:substring match 2)))
1446           (list (cond ((string=? len "breve") -1)
1447                       ((string=? len "longa") -2)
1448                       ((string=? len "maxima") -3)
1449                       (else (log2 (string->number len))))
1450                 (if dots (string-length dots) 0)))
1451         (ly:error (_ "not a valid duration string: ~a") duration-string))))
1452
1453 (define-builtin-markup-command (note layout props duration dir) (string? number?)
1454   "
1455 @cindex notes within text by string
1456
1457 This produces a note with a stem pointing in @var{dir} direction, with
1458 the @var{duration} for the note head type and augmentation dots.  For
1459 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
1460 a shortened down stem."
1461   (let ((parsed (parse-simple-duration duration)))
1462     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
1463 \f
1464 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1465 ;; translating.
1466 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1467
1468 (define-builtin-markup-command (lower layout props amount arg) (number? markup?)
1469   "
1470 @cindex lowering text
1471
1472 Lower @var{arg} by the distance @var{amount}.
1473 A negative @var{amount} indicates raising; see also @code{\\raise}."
1474   (ly:stencil-translate-axis (interpret-markup layout props arg)
1475                              (- amount) Y))
1476
1477 (define-builtin-markup-command (translate-scaled layout props offset arg) (number-pair? markup?)
1478   "
1479 @cindex translating text
1480 @cindex scaling text
1481
1482 Translate @var{arg} by @var{offset}, scaling the offset by the
1483 @code{font-size}."
1484   (let*
1485       ((factor (magstep (chain-assoc-get 'font-size props 0)))
1486        (scaled (cons (* factor (car offset))
1487                      (* factor (cdr offset)))))
1488
1489   (ly:stencil-translate (interpret-markup layout props arg)
1490                         scaled)))
1491
1492 (define-builtin-markup-command (raise layout props amount arg) (number? markup?)
1493   "
1494 @cindex raising text
1495
1496 Raise @var{arg} by the distance @var{amount}.
1497 A negative @var{amount} indicates lowering, see also @code{\\lower}.
1498
1499 The argument to @code{\\raise} is the vertical displacement amount,
1500 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
1501 raise objects in relation to their surrounding markups.
1502
1503 If the text object itself is positioned above or below the staff, then
1504 @code{\\raise} cannot be used to move it, since the mechanism that
1505 positions it next to the staff cancels any shift made with
1506 @code{\\raise}.  For vertical positioning, use the @code{padding}
1507 and/or @code{extra-offset} properties.
1508 @c
1509 @lilypond[verbatim,quote]
1510 \\markup { C \\small \\raise #1.0 \\bold { \"9/7+\" } }
1511 @end lilypond"
1512   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
1513
1514 (define-builtin-markup-command (fraction layout props arg1 arg2) (markup? markup?)
1515   "
1516 @cindex creating text fractions
1517
1518 Make a fraction of two markups."
1519   (let* ((m1 (interpret-markup layout props arg1))
1520          (m2 (interpret-markup layout props arg2))
1521          (factor (magstep (chain-assoc-get 'font-size props 0)))
1522          (boxdimen (cons (* factor -0.05) (* factor 0.05)))
1523          (padding (* factor 0.2))
1524          (baseline (* factor 0.6))
1525          (offset (* factor 0.75)))
1526     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
1527     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
1528     (let* ((x1 (ly:stencil-extent m1 X))
1529            (x2 (ly:stencil-extent m2 X))
1530            (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
1531            ;; should stack mols separately, to maintain LINE on baseline
1532            (stack (stack-lines DOWN padding baseline (list m1 line m2))))
1533       (set! stack
1534             (ly:stencil-aligned-to stack Y CENTER))
1535       (set! stack
1536             (ly:stencil-aligned-to stack X LEFT))
1537       ;; should have EX dimension
1538       ;; empirical anyway
1539       (ly:stencil-translate-axis stack offset Y))))
1540
1541 (define-builtin-markup-command (normal-size-super layout props arg) (markup?)
1542   "
1543 @cindex setting superscript in standard font size
1544
1545 Set @var{arg} in superscript with a normal font size."
1546   (ly:stencil-translate-axis
1547    (interpret-markup layout props arg)
1548    (* 0.5 (chain-assoc-get 'baseline-skip props)) Y))
1549
1550 (define-builtin-markup-command (super layout props arg) (markup?)
1551   "
1552 @cindex superscript text
1553
1554 Raising and lowering texts can be done with @code{\\super} and
1555 @code{\\sub}:
1556 @c
1557 @lilypond[verbatim,quote]
1558 \\markup { E \"=\" \\concat { \"mc\" \\super \"2\" } }
1559 @end lilypond"
1560   (ly:stencil-translate-axis
1561    (interpret-markup
1562     layout
1563     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
1564     arg)
1565    (* 0.5 (chain-assoc-get 'baseline-skip props))
1566    Y))
1567
1568 (define-builtin-markup-command (translate layout props offset arg) (number-pair? markup?)
1569   "
1570 @cindex translating text
1571
1572 This translates an object.  Its first argument is a cons of numbers.
1573
1574 @example
1575 A \\translate #(cons 2 -3) @{ B C @} D
1576 @end example
1577
1578 This moves @q{B C} 2@tie{}spaces to the right, and 3 down, relative to its
1579 surroundings.  This command cannot be used to move isolated scripts
1580 vertically, for the same reason that @code{\\raise} cannot be used for
1581 that."
1582   (ly:stencil-translate (interpret-markup  layout props arg)
1583                         offset))
1584
1585 (define-builtin-markup-command (sub layout props arg) (markup?)
1586   "
1587 @cindex subscript text
1588
1589 Set @var{arg} in subscript."
1590   (ly:stencil-translate-axis
1591    (interpret-markup
1592     layout
1593     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
1594     arg)
1595    (* -0.5 (chain-assoc-get 'baseline-skip props))
1596    Y))
1597
1598 (define-builtin-markup-command (normal-size-sub layout props arg) (markup?)
1599   "
1600 @cindex setting subscript in standard font size
1601
1602 Set @var{arg} in subscript, in a normal font size."
1603   (ly:stencil-translate-axis
1604    (interpret-markup layout props arg)
1605    (* -0.5 (chain-assoc-get 'baseline-skip props))
1606    Y))
1607 \f
1608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1609 ;; brackets.
1610 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1611
1612 (define-builtin-markup-command (hbracket layout props arg) (markup?)
1613   "
1614 @cindex placing horizontal brackets around text
1615
1616 Draw horizontal brackets around @var{arg}."
1617   (let ((th 0.1) ;; todo: take from GROB.
1618         (m (interpret-markup layout props arg)))
1619     (bracketify-stencil m X th (* 2.5 th) th)))
1620
1621 (define-builtin-markup-command (bracket layout props arg) (markup?)
1622   "
1623 @cindex placing vertical brackets around text
1624
1625 Draw vertical brackets around @var{arg}."
1626   (let ((th 0.1) ;; todo: take from GROB.
1627         (m (interpret-markup layout props arg)))
1628     (bracketify-stencil m Y th (* 2.5 th) th)))
1629 \f
1630 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1631 ;; Delayed markup evaluation
1632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1633
1634 (define-builtin-markup-command (page-ref layout props label gauge default)
1635   (symbol? markup? markup?)
1636   "
1637 @cindex referencing page numbers in text
1638
1639 Reference to a page number. @var{label} is the label set on the referenced
1640 page (using the @code{\\label} command), @var{gauge} a markup used to estimate
1641 the maximum width of the page number, and @var{default} the value to display
1642 when @var{label} is not found."
1643   (let* ((gauge-stencil (interpret-markup layout props gauge))
1644          (x-ext (ly:stencil-extent gauge-stencil X))
1645          (y-ext (ly:stencil-extent gauge-stencil Y)))
1646     (ly:make-stencil
1647      `(delay-stencil-evaluation
1648        ,(delay (ly:stencil-expr
1649                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
1650                        (label-page (and (list? table) (assoc label table)))
1651                        (page-number (and label-page (cdr label-page)))
1652                        (page-markup (if page-number (format "~a" page-number) default))
1653                        (page-stencil (interpret-markup layout props page-markup))
1654                        (gap (- (interval-length x-ext)
1655                                (interval-length (ly:stencil-extent page-stencil X)))))
1656                   (interpret-markup layout props
1657                                     (markup #:concat (#:hspace gap page-markup)))))))
1658      x-ext
1659      y-ext)))
1660 \f
1661 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1662 ;; Markup list commands
1663 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1664
1665 (define-public (space-lines baseline-skip lines)
1666   (map (lambda (line)
1667          (stack-lines DOWN 0.0 (/ baseline-skip 2.0)
1668                       (list point-stencil
1669                             line
1670                             point-stencil)))
1671        lines))
1672
1673 (define-builtin-markup-list-command (justified-lines layout props args) (markup-list?)
1674   "
1675 @cindex justifying lines of text
1676
1677 Like @code{\\justify}, but return a list of lines instead of a single markup.
1678 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
1679 @var{X}@tie{}is the number of staff spaces."
1680   (space-lines (chain-assoc-get 'baseline-skip props)
1681                (wordwrap-markups layout props args #t)))
1682
1683 (define-builtin-markup-list-command (wordwrap-lines layout props args) (markup-list?)
1684   "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
1685 Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
1686 where @var{X} is the number of staff spaces."
1687   (space-lines (chain-assoc-get 'baseline-skip props)
1688                (wordwrap-markups layout props args #f)))
1689
1690 (define-builtin-markup-list-command (column-lines layout props args) (markup-list?)
1691   "Like @code{\\column}, but return a list of lines instead of a single markup.
1692 @code{baseline-skip} determines the space between each markup in @var{args}."
1693   (space-lines (chain-assoc-get 'baseline-skip props)
1694                (interpret-markup-list layout props args)))
1695
1696 (define-builtin-markup-list-command (override-lines layout props new-prop args)
1697   (pair? markup-list?)
1698   "Like @code{\\override}, for markup lists."
1699   (interpret-markup-list layout (cons (list new-prop) props) args))