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