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