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--2005  Han-Wen Nienhuys <hanwen@cs.uu.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;; geometric shapes
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26
  27 (def-markup-command (draw-circle layout props radius thickness fill)
  28   (number? number? boolean?)
  29   "A circle of radius @var{radius}, thickness @var{thickness} and
  30 optionally filled."
  31   (make-circle-stencil radius thickness fill))
  32
  33 (def-markup-command (triangle layout props filled) (boolean?)
  34   "A triangle, filled or not"
  35   (let*
  36       ((th (chain-assoc-get 'thickness props  0.1))
  37        (size (chain-assoc-get 'font-size props 0))
  38        (ex (* (magstep size)
  39               0.8
  40               (chain-assoc-get 'baseline-skip props 2))))
  41
  42     (ly:make-stencil
  43      `(polygon '(0.0 0.0
  44                      ,ex 0.0
  45                      ,(* 0.5 ex)
  46                      ,(* 0.86 ex))
  47            ,th
  48            ,filled)
  49
  50      (cons 0 ex)
  51      (cons 0 (* .86 ex))
  52      )))
  53
  54 (def-markup-command (circle layout props arg) (markup?)
  55   "Draw a circle around @var{arg}.  Use @code{thickness},
  56 @code{circle-padding} and @code{font-size} properties to determine line
  57 thickness and padding around the markup."
  58   (let* ((th (chain-assoc-get 'thickness props  0.1))
  59          (size (chain-assoc-get 'font-size props 0))
  60          (pad
  61           (* (magstep size)
  62              (chain-assoc-get 'circle-padding props 0.2)))
  63          (m (interpret-markup layout props arg)))
  64     (circle-stencil m th pad)))
  65
  66 (def-markup-command (with-url layout props url arg) (string? markup?)
  67   "Add a link to URL @var{url} around @var{arg}. This only works in
  68 the PDF backend."
  69   (let* ((stil (interpret-markup layout props arg))
  70          (xextent (ly:stencil-extent stil X))
  71          (yextent (ly:stencil-extent stil Y))
  72          (old-expr (ly:stencil-expr stil))
  73          (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent))))
  74     (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
  75
  76
  77 (def-markup-command (beam layout props width slope thickness)
  78   (number? number? number?)
  79   "Create a beam with the specified parameters."
  80   (let* ((y (* slope width))
  81          (yext (cons (min 0 y) (max 0 y)))
  82          (half (/ thickness 2)))
  83
  84     (ly:make-stencil
  85      `(polygon ',(list
  86                   0 (/ thickness -2)
  87                     width (+ (* width slope)  (/ thickness -2))
  88                     width (+ (* width slope)  (/ thickness 2))
  89                     0 (/ thickness 2))
  90                ,(ly:output-def-lookup layout 'blotdiameter)
  91                #t)
  92      (cons 0 width)
  93      (cons (+ (- half) (car yext))
  94            (+ half (cdr yext))))))
  95
  96 (def-markup-command (box layout props arg) (markup?)
  97   "Draw a box round @var{arg}.  Looks at @code{thickness},
  98 @code{box-padding} and @code{font-size} properties to determine line
  99 thickness and padding around the markup."
 100   (let* ((th (chain-assoc-get 'thickness props  0.1))
 101          (size (chain-assoc-get 'font-size props 0))
 102          (pad (* (magstep size)
 103                  (chain-assoc-get 'box-padding props 0.2)))
 104          (m (interpret-markup layout props arg)))
 105     (box-stencil m th pad)))
 106
 107 (def-markup-command (filled-box layout props xext yext blot)
 108   (number-pair? number-pair? number?)
 109   "Draw a box with rounded corners of dimensions @var{xext} and @var{yext}."
 110   (ly:round-filled-box
 111    xext yext blot))
 112
 113 (def-markup-command (whiteout layout props arg) (markup?)
 114   "Provide a white underground for @var{arg}"
 115   (let* ((stil (interpret-markup layout props
 116                                  (make-with-color-markup black arg)))
 117          (white
 118           (interpret-markup layout props
 119                             (make-with-color-markup
 120                              white
 121                              (make-filled-box-markup
 122                               (ly:stencil-extent stil X)
 123                               (ly:stencil-extent stil Y)
 124                               0.0)))))
 125
 126     (ly:stencil-add white stil)))
 127
 128 (def-markup-command (pad-markup layout props padding arg) (number? markup?)
 129   "Add space around a markup object."
 130
 131   (let*
 132       ((stil (interpret-markup layout props arg))
 133        (xext (ly:stencil-extent stil X))
 134        (yext (ly:stencil-extent stil Y)))
 135
 136     (ly:make-stencil
 137      (ly:stencil-expr stil)
 138      (interval-widen xext padding)
 139      (interval-widen yext padding))))
 140
 141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 142 ;; space
 143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 144
 145 ;;FIXME: is this working?
 146 (def-markup-command (strut layout props) ()
 147   "Create a box of the same height as the space in the current font."
 148   (let ((m (Text_interface::interpret_markup layout props " ")))
 149     (ly:make-stencil (ly:stencil-expr m)
 150                      (ly:stencil-extent m X)
 151                      '(1000 . -1000))))
 152
 153
 154 ;; todo: fix negative space
 155 (def-markup-command (hspace layout props amount) (number?)
 156   "This produces a invisible object taking horizontal space.
 157 @example
 158 \\markup @{ A \\hspace #2.0 B @}
 159 @end example
 160 will put extra space between A and B, on top of the space that is
 161 normally inserted before elements on a line.
 162 "
 163   (if (> amount 0)
 164       (ly:make-stencil "" (cons 0 amount) '(-1 . 1))
 165       (ly:make-stencil "" (cons amount amount) '(-1 . 1))))
 166
 167
 168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 169 ;; importing graphics.
 170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171
 172 (def-markup-command (stencil layout props stil) (ly:stencil?)
 173   "Stencil as markup"
 174   stil)
 175
 176 (define bbox-regexp
 177   (make-regexp "%%BoundingBox:[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)[ \t]+([0-9-]+)"))
 178
 179 (define (get-postscript-bbox string)
 180   "Extract the bbox from STRING, or return #f if not present."
 181   (let*
 182       ((match (regexp-exec bbox-regexp string)))
 183
 184     (if match
 185         (map (lambda (x)
 186                (string->number (match:substring match x)))
 187              (cdr (iota 5)))
 188
 189         #f)))
 190
 191 (def-markup-command (epsfile layout props file-name) (string?)
 192   "Inline an EPS image. The image is scaled such that 10 PS units is
 193 one staff-space."
 194
 195   (if (ly:get-option 'safe)
 196       (interpret-markup layout props "not allowed in safe")
 197       (let*
 198           ((contents (ly:gulp-file file-name))
 199            (bbox (get-postscript-bbox contents))
 200            (scaled-bbox
 201             (if bbox
 202                 (map (lambda (x) (/ x 10)) bbox)
 203                 (begin
 204                   (ly:warning (_ "can't find bounding box of `~a'")
 205                            file-name)
 206                   '()))))
 207
 208
 209         (if bbox
 210
 211             (ly:make-stencil
 212              (list
 213               'embedded-ps
 214               (string-append
 215
 216                ; adobe 5002.
 217                "BeginEPSF "
 218                "0.1 0.1 scale "
 219                (format "\n%%BeginDocument: ~a\n" file-name)
 220                contents
 221                "%%EndDocument\n"
 222                "EndEPSF\n"
 223                ))
 224              (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
 225              (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
 226
 227             (ly:make-stencil "" '(0 . 0) '(0 . 0))))))
 228
 229
 230 (def-markup-command (postscript layout props str) (string?)
 231   "This inserts @var{str} directly into the output as a PostScript
 232 command string.  Due to technicalities of the output backends,
 233 different scales should be used for the @TeX{} and PostScript backend,
 234 selected with @code{-f}.
 235
 236
 237 For the TeX backend, the following string prints a rotated text
 238
 239 @cindex rotated text
 240
 241 @verbatim
 242 0 0 moveto /ecrm10 findfont
 243 1.75 scalefont setfont 90 rotate (hello) show
 244 @end verbatim
 245
 246 @noindent
 247 The magical constant 1.75 scales from LilyPond units (staff spaces) to
 248 TeX dimensions.
 249
 250 For the postscript backend, use the following
 251
 252 @verbatim
 253 gsave /ecrm10 findfont
 254  10.0 output-scale div
 255  scalefont setfont 90 rotate (hello) show grestore
 256 @end verbatim
 257 "
 258   ;; FIXME
 259   (ly:make-stencil
 260    (list 'embedded-ps str)
 261    '(0 . 0) '(0 . 0)))
 262
 263
 264 (def-markup-command (score layout props score) (ly:score?)
 265   "Inline an image of music."
 266   (let* ((output (ly:score-embedded-format score layout)))
 267
 268     (if (ly:music-output? output)
 269         (ly:paper-system-stencil
 270          (vector-ref (ly:paper-score-paper-systems output) 0))
 271         (begin
 272           (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?"))
 273           empty-stencil))))
 274
 275 (def-markup-command (null layout props) ()
 276   "An empty markup with extents of a single point"
 277
 278   point-stencil)
 279
 280 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 281 ;; basic formatting.
 282 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 283
 284 (def-markup-command (simple layout props str) (string?)
 285   "A simple text string; @code{\\markup @{ foo @}} is equivalent with
 286 @code{\\markup @{ \\simple #\"foo\" @}}."
 287   (interpret-markup layout props str))
 288
 289
 290 ;; TODO: use font recoding.
 291 ;;                    (make-line-markup
 292 ;;                     (map make-word-markup (string-tokenize str)))))
 293
 294 (define-public empty-markup
 295   (make-simple-markup ""))
 296
 297 ;; helper for justifying lines.
 298 (define (get-fill-space word-count line-width text-widths)
 299   "Calculate the necessary paddings between each two adjacent texts.
 300         The lengths of all texts are stored in @var{text-widths}.
 301         The normal formula for the padding between texts a and b is:
 302         padding = line-width/(word-count - 1) - (length(a) + length(b))/2
 303         The first and last padding have to be calculated specially using the
 304         whole length of the first or last text.
 305         Return a list of paddings.
 306 "
 307   (cond
 308    ((null? text-widths) '())
 309
 310    ;; special case first padding
 311    ((= (length text-widths) word-count)
 312     (cons
 313      (- (- (/ line-width (1- word-count)) (car text-widths))
 314         (/ (car (cdr text-widths)) 2))
 315      (get-fill-space word-count line-width (cdr text-widths))))
 316    ;; special case last padding
 317    ((= (length text-widths) 2)
 318     (list (- (/ line-width (1- word-count))
 319              (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0))
 320    (else
 321     (cons
 322      (- (/ line-width (1- word-count))
 323         (/ (+ (car text-widths) (car (cdr text-widths))) 2))
 324      (get-fill-space word-count line-width (cdr text-widths))))))
 325
 326 (def-markup-command (fill-line layout props markups)
 327   (markup-list?)
 328   "Put @var{markups} in a horizontal line of width @var{line-width}.
 329    The markups are spaced/flushed to fill the entire line.
 330    If there are no arguments, return an empty stencil."
 331
 332   (let* ((orig-stencils
 333           (map (lambda (x) (interpret-markup layout props x))
 334                markups))
 335          (stencils
 336           (map (lambda (stc)
 337                  (if (ly:stencil-empty? stc)
 338                      point-stencil
 339                      stc)) orig-stencils))
 340          (text-widths
 341           (map (lambda (stc)
 342                  (if (ly:stencil-empty? stc)
 343                      0.0
 344                      (interval-length (ly:stencil-extent stc X))))
 345                stencils))
 346          (text-width (apply + text-widths))
 347          (text-dir (chain-assoc-get 'text-direction props RIGHT))
 348          (word-count (length stencils))
 349          (word-space (chain-assoc-get 'word-space props))
 350          (line-width (chain-assoc-get 'linewidth props))
 351          (fill-space
 352                 (cond
 353                         ((= word-count 1)
 354                                 (list
 355                                         (/ (- line-width text-width) 2)
 356                                         (/ (- line-width text-width) 2)))
 357                         ((= word-count 2)
 358                                 (list
 359                                         (- line-width text-width)))
 360                         (else
 361                                 (get-fill-space word-count line-width text-widths))))
 362          (fill-space-normal
 363           (map (lambda (x)
 364                  (if (< x word-space)
 365                      word-space
 366                      x))
 367                fill-space))
 368
 369          (line-stencils (if (= word-count 1)
 370                             (list
 371                              point-stencil
 372                              (car stencils)
 373                              point-stencil)
 374                             stencils)))
 375
 376     (if (= text-dir LEFT)
 377         (set! line-stencils (reverse line-stencils)))
 378
 379     (if (null? (remove ly:stencil-empty? orig-stencils))
 380         empty-stencil
 381         (stack-stencils-padding-list X
 382                                      RIGHT fill-space-normal line-stencils))))
 383
 384 (def-markup-command (line layout props args) (markup-list?)
 385   "Put @var{args} in a horizontal line.  The property @code{word-space}
 386 determines the space between each markup in @var{args}."
 387   (let*
 388       ((stencils (map (lambda (m) (interpret-markup layout props m)) args))
 389        (space    (chain-assoc-get 'word-space props))
 390        (text-dir (chain-assoc-get 'text-direction props RIGHT))
 391        )
 392
 393
 394     (if (= text-dir LEFT)
 395         (set! stencils (reverse stencils)))
 396
 397
 398     (stack-stencil-line
 399      space
 400      (remove ly:stencil-empty? stencils))))
 401
 402
 403 (define (wordwrap-stencils stencils
 404                            justify base-space line-width text-dir)
 405
 406   "Perform simple wordwrap, return stencil of each line."
 407
 408   (define space (if justify
 409
 410                     ;; justify only stretches lines.
 411                     (* 0.7 base-space)
 412                     base-space))
 413
 414   (define (take-list width space stencils
 415                      accumulator accumulated-width)
 416     "Return (head-list . tail) pair, with head-list fitting into width"
 417     (if (null? stencils)
 418         (cons accumulator stencils)
 419         (let*
 420             ((first (car stencils))
 421              (first-wid (cdr (ly:stencil-extent (car stencils) X)))
 422              (newwid (+ space first-wid accumulated-width))
 423              )
 424
 425           (if
 426            (or (null? accumulator)
 427                (< newwid width))
 428
 429            (take-list width space
 430                       (cdr stencils)
 431                       (cons first accumulator)
 432                       newwid)
 433              (cons accumulator stencils))
 434            )))
 435
 436     (let loop
 437         ((lines '())
 438          (todo stencils))
 439
 440       (let*
 441           ((line-break (take-list line-width space todo
 442                                  '() 0.0))
 443            (line-stencils (car line-break))
 444            (space-left (- line-width (apply + (map (lambda (x) (cdr (ly:stencil-extent x X)))
 445                                               line-stencils))))
 446
 447            (line-word-space (cond
 448                              ((not justify) space)
 449
 450                              ;; don't stretch last line of paragraph.
 451                              ;; hmmm . bug - will overstretch the last line in some case.
 452                              ((null? (cdr line-break))
 453                               base-space)
 454                              ((null? line-stencils) 0.0)
 455                              ((null? (cdr line-stencils)) 0.0)
 456                              (else (/ space-left (1- (length line-stencils))))))
 457
 458            (line (stack-stencil-line
 459                   line-word-space
 460                   (if (= text-dir RIGHT)
 461                       (reverse line-stencils)
 462                       line-stencils))))
 463
 464         (if (pair? (cdr line-break))
 465             (loop (cons line lines)
 466                   (cdr line-break))
 467
 468             (begin
 469               (if (= text-dir LEFT)
 470                   (set! line
 471                         (ly:stencil-translate-axis line
 472                                                    (- line-width (interval-end (ly:stencil-extent line X)))
 473                                                    X)))
 474               (reverse (cons line lines))
 475
 476             )))
 477
 478       ))
 479
 480
 481 (define (wordwrap-markups layout props args justify)
 482   (let*
 483       ((baseline-skip (chain-assoc-get 'baseline-skip props))
 484        (line-width (chain-assoc-get 'linewidth props))
 485        (word-space (chain-assoc-get 'word-space props))
 486        (text-dir (chain-assoc-get 'text-direction props RIGHT))
 487        (lines (wordwrap-stencils
 488                (remove ly:stencil-empty?
 489                        (map (lambda (m) (interpret-markup layout props m)) args))
 490                justify word-space line-width
 491                text-dir)
 492                ))
 493
 494     (stack-lines DOWN 0.0 baseline-skip lines)))
 495
 496 (def-markup-command (justify layout props args) (markup-list?)
 497   "Like wordwrap, but with lines stretched to justify the margins.
 498 Use @code{\\override #'(linewidth . X)} to set linewidth, where X
 499 is the number of staff spaces."
 500
 501   (wordwrap-markups layout props args #t))
 502
 503 (def-markup-command (wordwrap layout props args) (markup-list?)
 504   "Simple wordwrap.  Use @code{\\override #'(linewidth . X)} to set
 505 linewidth, where X is the number of staff spaces."
 506
 507   (wordwrap-markups layout props args #f))
 508
 509 (define (wordwrap-string layout props justify arg)
 510   (let*
 511       ((baseline-skip (chain-assoc-get 'baseline-skip props))
 512        (line-width (chain-assoc-get 'linewidth props))
 513        (word-space (chain-assoc-get 'word-space props))
 514        (para-strings (regexp-split arg "\n[ \t\n]*\n[ \t\n]*"))
 515
 516        (text-dir (chain-assoc-get 'text-direction props RIGHT))
 517        (list-para-words (map (lambda (str)
 518                                (regexp-split str "[ \t\n]+"))
 519                              para-strings))
 520        (para-lines (map (lambda (words)
 521                           (let*
 522                               ((stencils
 523                                 (remove
 524                                  ly:stencil-empty? (map
 525                                       (lambda (x)
 526                                         (interpret-markup layout props x))
 527                                       words)))
 528                                (lines (wordwrap-stencils stencils
 529                                                          justify word-space
 530                                                          line-width text-dir
 531                                                          )))
 532
 533                             lines))
 534
 535                         list-para-words)))
 536
 537     (stack-lines DOWN 0.0 baseline-skip (apply append para-lines))))
 538
 539
 540 (def-markup-command (wordwrap-string layout props arg) (string?)
 541   "Wordwrap a string. Paragraphs may be separated with double newlines"
 542   (wordwrap-string layout props  #f arg))
 543
 544 (def-markup-command (justify-string layout props arg) (string?)
 545   "Justify a string. Paragraphs may be separated with double newlines"
 546   (wordwrap-string layout props #t arg))
 547
 548
 549 (def-markup-command (wordwrap-field layout props symbol) (symbol?)
 550    (let* ((m (chain-assoc-get symbol props)))
 551      (if (string? m)
 552       (interpret-markup layout props
 553        (list wordwrap-string-markup m))
 554       (ly:make-stencil '()  '(1 . -1) '(1 . -1)))))
 555
 556 (def-markup-command (justify-field layout props symbol) (symbol?)
 557    (let* ((m (chain-assoc-get symbol props)))
 558      (if (string? m)
 559       (interpret-markup layout props
 560        (list justify-string-markup m))
 561       (ly:make-stencil '()  '(1 . -1) '(1 . -1)))))
 562
 563
 564
 565 (def-markup-command (combine layout props m1 m2) (markup? markup?)
 566   "Print two markups on top of each other."
 567   (let* ((s1 (interpret-markup layout props m1))
 568          (s2 (interpret-markup layout props m2)))
 569     (ly:stencil-add s1 s2)))
 570
 571 ;;
 572 ;; TODO: should extract baseline-skip from each argument somehow..
 573 ;;
 574 (def-markup-command (column layout props args) (markup-list?)
 575   "Stack the markups in @var{args} vertically.  The property
 576 @code{baseline-skip} determines the space between each markup in @var{args}."
 577   (stack-lines
 578    -1 0.0 (chain-assoc-get 'baseline-skip props)
 579    (remove ly:stencil-empty?
 580            (map (lambda (m) (interpret-markup layout props m)) args))))
 581
 582 (def-markup-command (dir-column layout props args) (markup-list?)
 583   "Make a column of args, going up or down, depending on the setting
 584 of the @code{#'direction} layout property."
 585   (let* ((dir (chain-assoc-get 'direction props)))
 586     (stack-lines
 587      (if (number? dir) dir -1)
 588      0.0
 589      (chain-assoc-get 'baseline-skip props)
 590      (map (lambda (x) (interpret-markup layout props x)) args))))
 591
 592 (def-markup-command (center-align layout props args) (markup-list?)
 593   "Put @code{args} in a centered column. "
 594   (let* ((mols (map (lambda (x) (interpret-markup layout props x)) args))
 595          (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
 596     (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))
 597
 598 (def-markup-command (vcenter layout props arg) (markup?)
 599   "Align @code{arg} to its Y center. "
 600   (let* ((mol (interpret-markup layout props arg)))
 601     (ly:stencil-aligned-to mol Y CENTER)))
 602
 603 (def-markup-command (hcenter layout props arg) (markup?)
 604   "Align @code{arg} to its X center. "
 605   (let* ((mol (interpret-markup layout props arg)))
 606     (ly:stencil-aligned-to mol X CENTER)))
 607
 608 (def-markup-command (right-align layout props arg) (markup?)
 609   "Align @var{arg} on its right edge. "
 610   (let* ((m (interpret-markup layout props arg)))
 611     (ly:stencil-aligned-to m X RIGHT)))
 612
 613 (def-markup-command (left-align layout props arg) (markup?)
 614   "Align @var{arg} on its left edge. "
 615   (let* ((m (interpret-markup layout props arg)))
 616     (ly:stencil-aligned-to m X LEFT)))
 617
 618 (def-markup-command (general-align layout props axis dir arg)  (integer? number? markup?)
 619   "Align @var{arg} in @var{axis} direction to the @var{dir} side."
 620   (let* ((m (interpret-markup layout props arg)))
 621     (ly:stencil-aligned-to m axis dir)))
 622
 623 (def-markup-command (halign layout props dir arg) (number? markup?)
 624   "Set horizontal alignment. If @var{dir} is @code{-1}, then it is
 625 left-aligned, while @code{+1} is right. Values in between interpolate
 626 alignment accordingly."
 627   (let* ((m (interpret-markup layout props arg)))
 628     (ly:stencil-aligned-to m X dir)))
 629
 630
 631 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 632 ;; property
 633 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 634
 635 (def-markup-command (fromproperty layout props symbol) (symbol?)
 636   "Read the @var{symbol} from property settings, and produce a stencil
 637   from the markup contained within. If @var{symbol} is not defined, it
 638   returns an empty markup"
 639   (let* ((m (chain-assoc-get symbol props)))
 640     (if (markup? m)
 641         (interpret-markup layout props m)
 642         (ly:make-stencil '()  '(1 . -1) '(1 . -1)))))
 643
 644
 645 (def-markup-command (on-the-fly layout props procedure arg) (symbol? markup?)
 646   "Apply the @var{procedure} markup command to
 647 @var{arg}. @var{procedure} should take a single argument."
 648   (let* ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg))))
 649     (set-object-property! anonymous-with-signature
 650                           'markup-signature
 651                           (list markup?))
 652     (interpret-markup layout props (list anonymous-with-signature arg))))
 653
 654
 655
 656 (def-markup-command (override layout props new-prop arg) (pair? markup?)
 657   "Add the first argument in to the property list.  Properties may be
 658 any sort of property supported by @internalsref{font-interface} and
 659 @internalsref{text-interface}, for example
 660
 661 @verbatim
 662 \\override #'(font-family . married) \"bla\"
 663 @end verbatim
 664
 665 "
 666   (interpret-markup layout (cons (list new-prop) props) arg))
 667
 668 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 669 ;; fonts.
 670 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 671
 672
 673 (def-markup-command (bigger layout props arg) (markup?)
 674   "Increase the font size relative to current setting"
 675   (interpret-markup layout props
 676    `(,fontsize-markup 1 ,arg)))
 677
 678 (def-markup-command (smaller layout props arg) (markup?)
 679   "Decrease the font size relative to current setting"
 680   (interpret-markup layout props
 681    `(,fontsize-markup -1 ,arg)))
 682
 683 (def-markup-command larger (markup?) bigger-markup)
 684
 685 (def-markup-command (finger layout props arg) (markup?)
 686   "Set the argument as small numbers."
 687   (interpret-markup layout
 688                     (cons '((font-size . -5) (font-encoding . fetaNumber)) props)
 689                     arg))
 690
 691
 692 (def-markup-command (fontsize layout props increment arg) (number? markup?)
 693   "Add @var{increment} to the font-size. Adjust baseline skip accordingly."
 694
 695   (let* ((fs (chain-assoc-get 'font-size props 0))
 696          (bs (chain-assoc-get 'baseline-skip props 2))
 697          (entries (list
 698                    (cons 'baseline-skip (* bs (magstep increment)))
 699                    (cons 'font-size (+ fs increment )))))
 700
 701     (interpret-markup layout (cons entries props) arg)))
 702
 703
 704
 705 ;; FIXME -> should convert to font-size.
 706 (def-markup-command (magnify layout props sz arg) (number? markup?)
 707   "Set the font magnification for the its argument. In the following
 708 example, the middle A will be 10% larger:
 709 @example
 710 A \\magnify #1.1 @{ A @} A
 711 @end example
 712
 713 Note: magnification only works if a font-name is explicitly selected.
 714 Use @code{\\fontsize} otherwise."
 715   (interpret-markup
 716    layout
 717    (prepend-alist-chain 'font-magnification sz props)
 718    arg))
 719
 720 (def-markup-command (bold layout props arg) (markup?)
 721   "Switch to bold font-series"
 722   (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
 723
 724 (def-markup-command (sans layout props arg) (markup?)
 725   "Switch to the sans serif family"
 726   (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
 727
 728 (def-markup-command (number layout props arg) (markup?)
 729   "Set font family to @code{number}, which yields the font used for
 730 time signatures and fingerings.  This font only contains numbers and
 731 some punctuation. It doesn't have any letters.  "
 732   (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaNumber props) arg))
 733
 734 (def-markup-command (roman layout props arg) (markup?)
 735   "Set font family to @code{roman}."
 736   (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg))
 737
 738 (def-markup-command (huge layout props arg) (markup?)
 739   "Set font size to +2."
 740   (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
 741
 742 (def-markup-command (large layout props arg) (markup?)
 743   "Set font size to +1."
 744   (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
 745
 746 (def-markup-command (normalsize layout props arg) (markup?)
 747   "Set font size to default."
 748   (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
 749
 750 (def-markup-command (small layout props arg) (markup?)
 751   "Set font size to -1."
 752   (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
 753
 754 (def-markup-command (tiny layout props arg) (markup?)
 755   "Set font size to -2."
 756   (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
 757
 758 (def-markup-command (teeny layout props arg) (markup?)
 759   "Set font size to -3."
 760   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
 761
 762 (def-markup-command (caps layout props arg) (markup?)
 763   "Set @code{font-shape} to @code{caps}."
 764   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
 765
 766 (def-markup-command (dynamic layout props arg) (markup?)
 767   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
 768 @b{z}, @b{p}, and @b{r}.  When producing phrases, like ``pi@`{u} @b{f}'', the
 769 normal words (like ``pi@`{u}'') should be done in a different font.  The
 770 recommend font for this is bold and italic"
 771   (interpret-markup
 772    layout (prepend-alist-chain 'font-encoding 'fetaDynamic props) arg))
 773
 774 (def-markup-command (text layout props arg) (markup?)
 775   "Use a text font instead of music symbol or music alphabet font."
 776
 777   ;; ugh - latin1
 778   (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props)
 779                     arg))
 780
 781
 782 (def-markup-command (italic layout props arg) (markup?)
 783   "Use italic @code{font-shape} for @var{arg}. "
 784   (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg))
 785
 786 (def-markup-command (typewriter layout props arg) (markup?)
 787   "Use @code{font-family} typewriter for @var{arg}."
 788   (interpret-markup
 789    layout (prepend-alist-chain 'font-family 'typewriter props) arg))
 790
 791 (def-markup-command (upright layout props arg) (markup?)
 792   "Set font shape to @code{upright}.  This is the opposite of @code{italic}."
 793   (interpret-markup
 794    layout (prepend-alist-chain 'font-shape 'upright props) arg))
 795
 796 (def-markup-command (medium layout props arg) (markup?)
 797   "Switch to medium font-series (in contrast to bold)."
 798   (interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
 799                     arg))
 800
 801 (def-markup-command (normal-text layout props arg) (markup?)
 802   "Set all font related properties (except the size) to get the default normal text font, no matter what font was used earlier."
 803   ;; ugh - latin1
 804   (interpret-markup layout
 805                     (cons '((font-family . roman) (font-shape . upright)
 806                             (font-series . medium) (font-encoding . latin1))
 807                           props)
 808                     arg))
 809
 810 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 811 ;; symbols.
 812 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 813
 814 (def-markup-command (doublesharp layout props) ()
 815   "Draw a double sharp symbol."
 816
 817   (interpret-markup layout props (markup #:musicglyph "accidentals.4")))
 818
 819 (def-markup-command (sesquisharp layout props) ()
 820   "Draw a 3/2 sharp symbol."
 821   (interpret-markup layout props (markup #:musicglyph "accidentals.3")))
 822
 823 (def-markup-command (sharp layout props) ()
 824   "Draw a sharp symbol."
 825   (interpret-markup layout props (markup #:musicglyph "accidentals.2")))
 826
 827 (def-markup-command (semisharp layout props) ()
 828   "Draw a semi sharp symbol."
 829   (interpret-markup layout props (markup #:musicglyph "accidentals.1")))
 830
 831 (def-markup-command (natural layout props) ()
 832   "Draw a natural symbol."
 833   (interpret-markup layout props (markup #:musicglyph "accidentals.0")))
 834
 835 (def-markup-command (semiflat layout props) ()
 836   "Draw a semiflat."
 837   (interpret-markup layout props (markup #:musicglyph "accidentals.M1")))
 838
 839 (def-markup-command (flat layout props) ()
 840   "Draw a flat symbol."
 841   (interpret-markup layout props (markup #:musicglyph "accidentals.M2")))
 842
 843 (def-markup-command (sesquiflat layout props) ()
 844   "Draw a 3/2 flat symbol."
 845   (interpret-markup layout props (markup #:musicglyph "accidentals.M3")))
 846
 847 (def-markup-command (doubleflat layout props) ()
 848   "Draw a double flat symbol."
 849   (interpret-markup layout props (markup #:musicglyph "accidentals.M4")))
 850
 851 (def-markup-command (with-color layout props color arg) (color? markup?)
 852   "Draw @var{arg} in color specified by @var{color}"
 853
 854   (let* ((stil (interpret-markup layout props arg)))
 855
 856     (ly:make-stencil (list 'color color (ly:stencil-expr stil))
 857                      (ly:stencil-extent stil X)
 858                      (ly:stencil-extent stil Y))))
 859
 860 \f
 861 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 862 ;; glyphs
 863 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 864
 865
 866 (def-markup-command (arrow-head layout props axis direction filled)
 867   (integer? ly:dir? boolean?)
 868   "produce an arrow head in specified direction and axis. Use the filled head if @var{filled} is  specified."
 869   (let*
 870       ((name (format "arrowheads.~a.~a~a"
 871                      (if filled
 872                          "close"
 873                          "open")
 874                      axis
 875                      direction)))
 876     (ly:font-get-glyph
 877      (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
 878                                      props))
 879      name)))
 880
 881 (def-markup-command (musicglyph layout props glyph-name) (string?)
 882   "This is converted to a musical symbol, e.g. @code{\\musicglyph
 883 #\"accidentals.0\"} will select the natural sign from the music font.
 884 See @usermanref{The Feta font} for  a complete listing of the possible glyphs."
 885   (ly:font-get-glyph
 886    (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
 887                                    props))
 888    glyph-name))
 889
 890 (def-markup-command (lookup layout props glyph-name) (string?)
 891   "Lookup a glyph by name."
 892   (ly:font-get-glyph (ly:paper-get-font layout props)
 893                      glyph-name))
 894
 895 (def-markup-command (char layout props num) (integer?)
 896   "Produce a single character, e.g. @code{\\char #65} produces the
 897 letter 'A'."
 898   (ly:get-glyph (ly:paper-get-font layout props) num))
 899
 900
 901 (define number->mark-letter-vector (make-vector 25 #\A))
 902
 903 (do ((i 0 (1+ i))
 904      (j 0 (1+ j)))
 905     ((>= i 26))
 906   (if (= i (- (char->integer #\I) (char->integer #\A)))
 907       (set! i (1+ i)))
 908   (vector-set! number->mark-letter-vector j
 909                (integer->char (+ i (char->integer #\A)))))
 910
 911 (define number->mark-alphabet-vector (list->vector
 912   (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26))))
 913
 914 (define (number->markletter-string vec n)
 915   "Double letters for big marks."
 916   (let* ((lst (vector-length vec)))
 917
 918     (if (>= n lst)
 919         (string-append (number->markletter-string vec (1- (quotient n lst)))
 920                        (number->markletter-string vec (remainder n lst)))
 921         (make-string 1 (vector-ref vec n)))))
 922
 923 (def-markup-command (markletter layout props num) (integer?)
 924   "Make a markup letter for @var{num}.  The letters start with A to Z
 925  (skipping I), and continues with double letters."
 926   (Text_interface::interpret_markup layout props
 927     (number->markletter-string number->mark-letter-vector num)))
 928
 929 (def-markup-command (markalphabet layout props num) (integer?)
 930    "Make a markup letter for @var{num}.  The letters start with A to Z
 931  and continues with double letters."
 932    (Text_interface::interpret_markup layout props
 933      (number->markletter-string number->mark-alphabet-vector num)))
 934
 935 \f
 936 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 937 ;; the note command.
 938 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 939
 940
 941 ;; TODO: better syntax.
 942
 943 (def-markup-command (note-by-number layout props log dot-count dir) (number? number? number?)
 944   "Construct a note symbol, with stem.  By using fractional values for
 945 @var{dir}, you can obtain longer or shorter stems."
 946   (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) props)))
 947          (size (chain-assoc-get 'font-size props 0))
 948          (stem-length (* (magstep size) (max 3 (- log 1))))
 949          (head-glyph (ly:font-get-glyph
 950                       font
 951                       (string-append "noteheads.s" (number->string (min log 2)))))
 952          (stem-thickness 0.13)
 953          (stemy (* dir stem-length))
 954          (attachx (if (> dir 0)
 955                       (- (cdr (ly:stencil-extent head-glyph X)) stem-thickness)
 956                       0))
 957          (attachy (* dir 0.28))
 958          (stem-glyph (and (> log 0)
 959                           (ly:round-filled-box
 960                            (cons attachx (+ attachx  stem-thickness))
 961                            (cons (min stemy attachy)
 962                                  (max stemy attachy))
 963                            (/ stem-thickness 3))))
 964          (dot (ly:font-get-glyph font "dots.dot"))
 965          (dotwid (interval-length (ly:stencil-extent dot X)))
 966          (dots (and (> dot-count 0)
 967                     (apply ly:stencil-add
 968                            (map (lambda (x)
 969                                   (ly:stencil-translate-axis
 970                                    dot  (* (+ 1 (* 2 x)) dotwid) X))
 971                                 (iota dot-count 1)))))
 972          (flaggl (and (> log 2)
 973                       (ly:stencil-translate
 974                        (ly:font-get-glyph font
 975                                           (string-append "flags."
 976                                                          (if (> dir 0) "u" "d")
 977                                                          (number->string log)))
 978                        (cons (+ attachx (/ stem-thickness 2)) stemy)))))
 979     (if flaggl
 980         (set! stem-glyph (ly:stencil-add flaggl stem-glyph)))
 981     (if (ly:stencil? stem-glyph)
 982         (set! stem-glyph (ly:stencil-add stem-glyph head-glyph))
 983         (set! stem-glyph head-glyph))
 984     (if (ly:stencil? dots)
 985         (set! stem-glyph
 986               (ly:stencil-add
 987                (ly:stencil-translate-axis
 988                 dots
 989                 (+ (if (and (> dir 0) (> log 2))
 990                        (* 1.5 dotwid)
 991                        0)
 992                    ;; huh ? why not necessary?
 993                    ;;(cdr (ly:stencil-extent head-glyph X))
 994                    dotwid)
 995                 X)
 996                stem-glyph)))
 997     stem-glyph))
 998
 999 (define-public log2
1000   (let ((divisor (log 2)))
1001     (lambda (z) (inexact->exact (/ (log z) divisor)))))
1002
1003 (define (parse-simple-duration duration-string)
1004   "Parse the `duration-string', e.g. ''4..'' or ''breve.'', and return a (log dots) list."
1005   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string)))
1006     (if (and match (string=? duration-string (match:substring match 0)))
1007         (let ((len  (match:substring match 1))
1008               (dots (match:substring match 2)))
1009           (list (cond ((string=? len "breve") -1)
1010                       ((string=? len "longa") -2)
1011                       ((string=? len "maxima") -3)
1012                       (else (log2 (string->number len))))
1013                 (if dots (string-length dots) 0)))
1014         (ly:error (_ "not a valid duration string: ~a") duration-string))))
1015
1016 (def-markup-command (note layout props duration dir) (string? number?)
1017   "This produces a note with a stem pointing in @var{dir} direction, with
1018 the @var{duration} for the note head type and augmentation dots. For
1019 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
1020 a shortened down stem."
1021   (let ((parsed (parse-simple-duration duration)))
1022     (note-by-number-markup layout props (car parsed) (cadr parsed) dir)))
1023
1024 \f
1025 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1026 ;; translating.
1027 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1028
1029 (def-markup-command (lower layout props amount arg) (number? markup?)
1030   "
1031 Lower @var{arg}, by the distance @var{amount}.
1032 A negative @var{amount} indicates raising, see also @code{\raise}.
1033 "
1034   (ly:stencil-translate-axis (interpret-markup layout props arg)
1035                              (- amount) Y))
1036
1037
1038 (def-markup-command (raise layout props amount arg) (number? markup?)
1039   "
1040 Raise @var{arg}, by the distance @var{amount}.
1041 A negative @var{amount} indicates lowering, see also @code{\\lower}.
1042 @c
1043 @lilypond[verbatim,fragment,relative=1]
1044  c1^\\markup { C \\small \\raise #1.0 \\bold { \"9/7+\" }}
1045 @end lilypond
1046 The argument to @code{\\raise} is the vertical displacement amount,
1047 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
1048 raise objects in relation to their surrounding markups.
1049
1050 If the text object itself is positioned above or below the staff, then
1051 @code{\\raise} cannot be used to move it, since the mechanism that
1052 positions it next to the staff cancels any shift made with
1053 @code{\\raise}. For vertical positioning, use the @code{padding}
1054 and/or @code{extra-offset} properties. "
1055   (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
1056
1057 (def-markup-command (fraction layout props arg1 arg2) (markup? markup?)
1058   "Make a fraction of two markups."
1059   (let* ((m1 (interpret-markup layout props arg1))
1060          (m2 (interpret-markup layout props arg2)))
1061     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
1062     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
1063     (let* ((x1 (ly:stencil-extent m1 X))
1064            (x2 (ly:stencil-extent m2 X))
1065            (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0))
1066            ;; should stack mols separately, to maintain LINE on baseline
1067            (stack (stack-lines -1 0.2 0.6 (list m1 line m2))))
1068       (set! stack
1069             (ly:stencil-aligned-to stack Y CENTER))
1070       (set! stack
1071             (ly:stencil-aligned-to stack X LEFT))
1072       ;; should have EX dimension
1073       ;; empirical anyway
1074       (ly:stencil-translate-axis stack 0.75 Y))))
1075
1076
1077
1078
1079
1080 (def-markup-command (normal-size-super layout props arg) (markup?)
1081   "Set @var{arg} in superscript with a normal font size."
1082   (ly:stencil-translate-axis
1083    (interpret-markup layout props arg)
1084    (* 0.5 (chain-assoc-get 'baseline-skip props)) Y))
1085
1086 (def-markup-command (super layout props arg) (markup?)
1087   "
1088 @cindex raising text
1089 @cindex lowering text
1090 @cindex moving text
1091 @cindex translating text
1092
1093 @cindex @code{\\super}
1094
1095
1096 Raising and lowering texts can be done with @code{\\super} and
1097 @code{\\sub}:
1098
1099 @lilypond[verbatim,fragment,relative=1]
1100  c1^\\markup { E \"=\" mc \\super \"2\" }
1101 @end lilypond
1102
1103 "
1104   (ly:stencil-translate-axis
1105    (interpret-markup
1106     layout
1107     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
1108     arg)
1109    (* 0.5 (chain-assoc-get 'baseline-skip props))
1110    Y))
1111
1112 (def-markup-command (translate layout props offset arg) (number-pair? markup?)
1113   "This translates an object. Its first argument is a cons of numbers
1114 @example
1115 A \\translate #(cons 2 -3) @{ B C @} D
1116 @end example
1117 This moves `B C' 2 spaces to the right, and 3 down, relative to its
1118 surroundings. This command cannot be used to move isolated scripts
1119 vertically, for the same reason that @code{\\raise} cannot be used for
1120 that.
1121
1122 "
1123   (ly:stencil-translate (interpret-markup  layout props arg)
1124                         offset))
1125
1126 (def-markup-command (sub layout props arg) (markup?)
1127   "Set @var{arg} in subscript."
1128   (ly:stencil-translate-axis
1129    (interpret-markup
1130     layout
1131     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
1132     arg)
1133    (* -0.5 (chain-assoc-get 'baseline-skip props))
1134    Y))
1135
1136 (def-markup-command (normal-size-sub layout props arg) (markup?)
1137   "Set @var{arg} in subscript, in a normal font size."
1138   (ly:stencil-translate-axis
1139    (interpret-markup layout props arg)
1140    (* -0.5 (chain-assoc-get 'baseline-skip props))
1141    Y))
1142 \f
1143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1144 ;; brackets.
1145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1146
1147 (def-markup-command (hbracket layout props arg) (markup?)
1148   "Draw horizontal brackets around @var{arg}."
1149   (let ((th 0.1) ;; todo: take from GROB.
1150         (m (interpret-markup layout props arg)))
1151     (bracketify-stencil m X th (* 2.5 th) th)))
1152
1153 (def-markup-command (bracket layout props arg) (markup?)
1154   "Draw vertical brackets around @var{arg}."
1155   (let ((th 0.1) ;; todo: take from GROB.
1156         (m (interpret-markup layout props arg)))
1157     (bracketify-stencil m Y th (* 2.5 th) th)))
1158
1159 (def-markup-command (bracketed-y-column layout props indices args)
1160   (list? markup-list?)
1161   "Make a column of the markups in @var{args}, putting brackets around
1162 the elements marked in @var{indices}, which is a list of numbers."
1163   (define (sublist lst start stop)
1164     (take (drop lst start) (- (1+ stop) start)))
1165
1166   (define (stencil-list-extent ss axis)
1167     (cons
1168      (apply min (map (lambda (x) (car (ly:stencil-extent x axis))) ss))
1169      (apply max (map (lambda (x) (cdr (ly:stencil-extent x axis))) ss))))
1170
1171
1172   (define (stack-stencils-vertically stencils bskip last-stencil)
1173     (cond
1174      ((null? stencils) '())
1175      ((not (ly:stencil? last-stencil))
1176       (cons (car stencils)
1177             (stack-stencils-vertically (cdr stencils) bskip (car stencils))))
1178      (else
1179       (let* ((orig (car stencils))
1180              (dir (chain-assoc-get 'direction  props DOWN))
1181              (new (ly:stencil-moved-to-edge last-stencil Y dir
1182                                             orig
1183                                             0.1 bskip)))
1184
1185         (cons new (stack-stencils-vertically (cdr stencils) bskip new))))))
1186
1187   (define (make-brackets stencils indices acc)
1188     (if (and stencils
1189              (pair? indices)
1190              (pair? (cdr indices)))
1191         (let* ((encl (sublist stencils (car indices) (cadr indices)))
1192                (x-ext (stencil-list-extent encl X))
1193                (y-ext (stencil-list-extent encl Y))
1194                (thick 0.10)
1195                (pad 0.35)
1196                (protusion (* 2.5 thick))
1197                (lb
1198                 (ly:stencil-translate-axis
1199                  (ly:bracket Y y-ext thick protusion)
1200                  (- (car x-ext) pad) X))
1201                (rb (ly:stencil-translate-axis
1202                     (ly:bracket Y y-ext thick (- protusion))
1203                     (+ (cdr x-ext) pad) X)))
1204
1205           (make-brackets
1206            stencils (cddr indices)
1207            (append
1208             (list lb rb)
1209             acc)))
1210         acc))
1211
1212   (let* ((stencils
1213           (map (lambda (x)
1214                  (interpret-markup
1215                   layout
1216                   props
1217                   x)) args))
1218          (leading
1219           (chain-assoc-get 'baseline-skip props))
1220          (stacked (stack-stencils-vertically
1221                    (remove ly:stencil-empty? stencils) 1.25 #f))
1222          (brackets (make-brackets stacked indices '())))
1223
1224     (apply ly:stencil-add
1225            (append stacked brackets))))