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