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