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