scm/define-markup-commands.scm

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