scm/define-markup-commands.scm

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