scm/define-markup-commands.scm

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