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