scm/define-markup-commands.scm

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