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