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