scm/output-svg.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2002--2014 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;;                Patrick McCarty <pnorcks@gmail.com>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (scm output-svg))
  20
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;; globals
  23
  24 ;;; set by framework-gnome.scm
  25 (define paper #f)
  26
  27 (use-modules
  28  (guile)
  29  (ice-9 regex)
  30  (ice-9 format)
  31  (ice-9 optargs)
  32  (lily)
  33  (srfi srfi-1)
  34  (srfi srfi-13))
  35
  36 (define fancy-format format)
  37 (define format ergonomic-simple-format)
  38
  39 (define lily-unit-length 1.7573)
  40
  41 ;; Helper functions
  42 (define-public (attributes attributes-alist)
  43   (string-concatenate
  44    (map (lambda (x)
  45           (let ((attr (car x))
  46                 (value (cdr x)))
  47             (if (number? value)
  48                 (set! value (ly:format "~4f" value)))
  49             (format #f " ~s=\"~a\"" attr value)))
  50         attributes-alist)))
  51
  52 (define-public (eo entity . attributes-alist)
  53   "o = open"
  54   (format #f "<~S~a>\n" entity (attributes attributes-alist)))
  55
  56 (define-public (eoc entity . attributes-alist)
  57   "oc = open/close"
  58   (format #f "<~S~a/>\n" entity (attributes attributes-alist)))
  59
  60 (define-public (ec entity)
  61   "c = close"
  62   (format #f "</~S>\n" entity))
  63
  64 (define (start-enclosing-id-node s)
  65   (string-append "<g id=\"" s "\">\n"))
  66
  67 (define (end-enclosing-id-node)
  68   "</g>\n")
  69
  70 (define-public (comment s)
  71   (string-append "<!-- " s " -->\n"))
  72
  73 (define-public (entity entity string . attributes-alist)
  74   (if (equal? string "")
  75       (apply eoc entity attributes-alist)
  76       (string-append
  77        (apply eo (cons entity attributes-alist)) string (ec entity))))
  78
  79 (define (offset->point o)
  80   (ly:format "~4f ~4f" (car o) (- (cdr o))))
  81
  82 (define (number-list->point lst)
  83   (define (helper lst)
  84     (if (null? lst)
  85         '()
  86         (cons (format #f "~S ~S" (car lst) (- (cadr lst)))
  87               (helper (cddr lst)))))
  88
  89   (string-join (helper lst) " "))
  90
  91
  92 (define (svg-bezier lst close)
  93   (let* ((c0 (car (list-tail lst 3)))
  94          (c123 (list-head lst 3)))
  95     (string-append
  96      (if (not close) "M" "L")
  97      (offset->point c0)
  98      "C" (string-join (map offset->point c123) " ")
  99      (if (not close) "" "z"))))
 100
 101 (define (sqr x)
 102   (* x x))
 103
 104 (define (integer->entity integer)
 105   (fancy-format "&#x~x;" integer))
 106
 107 (define (char->entity char)
 108   (integer->entity (char->integer char)))
 109
 110 (define (string->entities string)
 111   (string-concatenate
 112    (map char->entity (string->list string))))
 113
 114 (define svg-element-regexp
 115   (make-regexp "^(<[a-z]+) ?(.*>)"))
 116
 117 (define scaled-element-regexp
 118   (make-regexp "^(<[a-z]+ transform=\")(scale.[-0-9. ]+,[-0-9. ]+.\" .*>)"))
 119
 120 (define pango-description-regexp-comma
 121   (make-regexp ",( Bold)?( Italic)?( Small-Caps)?[ -]([0-9.]+)$"))
 122
 123 (define pango-description-regexp-nocomma
 124   (make-regexp "( Bold)?( Italic)?( Small-Caps)?[ -]([0-9.]+)$"))
 125
 126 (define (pango-description-to-text str expr)
 127   (define alist '())
 128   (define (set-attribute attr val)
 129     (set! alist (assoc-set! alist attr val)))
 130   (let* ((match-1 (regexp-exec pango-description-regexp-comma str))
 131          (match-2 (regexp-exec pango-description-regexp-nocomma str))
 132          (match (if match-1 match-1 match-2)))
 133
 134     (if (regexp-match? match)
 135         (begin
 136           (set-attribute 'font-family (match:prefix match))
 137           (if (string? (match:substring match 1))
 138               (set-attribute 'font-weight "bold"))
 139           (if (string? (match:substring match 2))
 140               (set-attribute 'font-style "italic"))
 141           (if (string? (match:substring match 3))
 142               (set-attribute 'font-variant "small-caps"))
 143           (set-attribute 'font-size
 144                          (/ (string->number (match:substring match 4))
 145                             lily-unit-length))
 146           (set-attribute 'text-anchor "start")
 147           (set-attribute 'fill "currentColor"))
 148         (ly:warning (_ "cannot decypher Pango description: ~a") str))
 149
 150     (apply entity 'text expr (reverse! alist))))
 151
 152 (define (dump-path path scale . rest)
 153   (define alist '())
 154   (define (set-attribute attr val)
 155     (set! alist (assoc-set! alist attr val)))
 156   (if (not (null? rest))
 157       (let* ((dx (car rest))
 158              (dy (cadr rest))
 159              (total-x (+ dx next-horiz-adv)))
 160         (if (or (not (zero? total-x))
 161                 (not (zero? dy)))
 162             (let ((x (ly:format "~4f" total-x))
 163                   (y (ly:format "~4f" dy)))
 164               (set-attribute 'transform
 165                              (string-append
 166                               "translate(" x ", " y ") "
 167                               "scale(" scale ", -" scale ")")))
 168             (set-attribute 'transform
 169                            (string-append
 170                             "scale(" scale ", -" scale ")"))))
 171       (set-attribute 'transform (string-append
 172                                  "scale(" scale ", -" scale ")")))
 173
 174   (set-attribute 'd path)
 175   (set-attribute 'fill "currentColor")
 176   (apply entity 'path "" (reverse alist)))
 177
 178
 179 ;; A global variable for keeping track of the *cumulative*
 180 ;; horizontal advance for glyph strings, but only if there
 181 ;; is more than one glyph.
 182 (define next-horiz-adv 0.0)
 183
 184 ;; Matches the required "unicode" attribute from <glyph>
 185 (define glyph-unicode-value-regexp
 186   (make-regexp "unicode=\"([^\"]+)\""))
 187
 188 ;; Matches the optional path data from <glyph>
 189 (define glyph-path-regexp
 190   (make-regexp "d=\"([-MmZzLlHhVvCcSsQqTt0-9.\n ]*)\""))
 191
 192 ;; Matches a complete <glyph> element with the glyph-name
 193 ;; attribute value of NAME.  For example:
 194 ;;
 195 ;; <glyph glyph-name="period" unicode="." horiz-adv-x="110"
 196 ;; d="M0 55c0 30 25 55 55 55s55 -25 55
 197 ;; -55s-25 -55 -55 -55s-55 25 -55 55z" />
 198 ;;
 199 ;; TODO: it would be better to use an XML library to extract
 200 ;; the glyphs instead, and store them in a hash table.  --pmccarty
 201 ;;
 202 (define (glyph-element-regexp name)
 203   (make-regexp (string-append "<glyph"
 204                               "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
 205                               "[[:space:]]+glyph-name=\"("
 206                               name
 207                               ")\""
 208                               "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
 209                               "([[:space:]]+)?"
 210                               "/>")))
 211
 212 (define (extract-glyph all-glyphs name size . rest)
 213   (let* ((new-name (regexp-quote name))
 214          (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
 215          (glyph (match:substring regexp))
 216          (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
 217          (unicode-attr-value (match:substring unicode-attr 1))
 218          (unicode-attr? (regexp-match? unicode-attr))
 219          (d-attr (regexp-exec glyph-path-regexp glyph))
 220          (d-attr-value "")
 221          (d-attr? (regexp-match? d-attr))
 222          ;; TODO: not urgent, but do not hardcode this value
 223          (units-per-em 1000)
 224          (font-scale (ly:format "~4f" (/ size units-per-em)))
 225          (path ""))
 226
 227     (if (and unicode-attr? (not unicode-attr-value))
 228         (ly:warning (_ "Glyph must have a unicode value")))
 229
 230     (if d-attr? (set! d-attr-value (match:substring d-attr 1)))
 231
 232     (cond (
 233            ;; Glyph-strings with path data
 234            (and d-attr? (not (null? rest)))
 235            (begin
 236              (set! path (apply dump-path d-attr-value
 237                                font-scale
 238                                (list (caddr rest) (cadddr rest))))
 239              (set! next-horiz-adv (+ next-horiz-adv
 240                                      (car rest)))
 241              path))
 242           ;; Glyph-strings without path data ("space")
 243           ((and (not d-attr?) (not (null? rest)))
 244            (begin
 245              (set! next-horiz-adv (+ next-horiz-adv
 246                                      (car rest)))
 247              ""))
 248           ;; Font smobs with path data
 249           ((and d-attr? (null? rest))
 250            (set! path (dump-path d-attr-value font-scale))
 251            path)
 252           ;; Font smobs without path data ("space")
 253           (else
 254            ""))))
 255
 256 (define (extract-glyph-info all-glyphs glyph size)
 257   (let* ((offsets (list-head glyph 4))
 258          (glyph-name (car (reverse glyph))))
 259     (apply extract-glyph all-glyphs glyph-name size offsets)))
 260
 261 (define (svg-defs svg-font)
 262   (let ((start (string-contains svg-font "<defs>"))
 263         (end (string-contains svg-font "</defs>")))
 264     (substring svg-font (+ start 7) (- end 1))))
 265
 266 (define (cache-font svg-font size glyph)
 267   (let ((all-glyphs (svg-defs (cached-file-contents svg-font))))
 268     (if (list? glyph)
 269         (extract-glyph-info all-glyphs glyph size)
 270         (extract-glyph all-glyphs glyph size))))
 271
 272
 273 (define (music-string-to-path font size glyph)
 274   (let* ((name-style (font-name-style font))
 275          (scaled-size (/ size lily-unit-length))
 276          (font-file (ly:find-file (string-append name-style ".svg"))))
 277
 278     (if font-file
 279         (cache-font font-file scaled-size glyph)
 280         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 281
 282
 283 (define (font-smob-to-path font glyph)
 284   (let* ((name-style (font-name-style font))
 285          (scaled-size (modified-font-metric-font-scaling font))
 286          (font-file (ly:find-file (string-append name-style ".svg"))))
 287
 288     (if font-file
 289         (cache-font font-file scaled-size glyph)
 290         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 291
 292 (define (woff-font-smob-to-text font expr)
 293   (let* ((name-style (font-name-style font))
 294          (scaled-size (modified-font-metric-font-scaling font))
 295          (font-file (ly:find-file (string-append name-style ".woff")))
 296          (charcode (ly:font-glyph-name-to-charcode font expr))
 297          (char-lookup (format #f "&#~S;" charcode))
 298          (glyph-by-name (eoc 'altglyph `(glyphname . ,expr)))
 299          (apparently-broken
 300           (comment "FIXME: how to select glyph by name, altglyph is broken?"))
 301          (text (string-regexp-substitute "\n" ""
 302                                          (string-append glyph-by-name apparently-broken char-lookup))))
 303     (define alist '())
 304     (define (set-attribute attr val)
 305       (set! alist (assoc-set! alist attr val)))
 306     (set-attribute 'font-family name-style)
 307     (set-attribute 'font-size scaled-size)
 308     (apply entity 'text text (reverse! alist))))
 309
 310 (define font-smob-to-text
 311   (if (not (ly:get-option 'svg-woff))
 312       font-smob-to-path woff-font-smob-to-text))
 313
 314 (define (fontify font expr)
 315   (if (string? font)
 316       (pango-description-to-text font expr)
 317       (font-smob-to-text font expr)))
 318
 319 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 320 ;;; stencil outputters
 321 ;;;
 322
 323 (define (char font i)
 324   (fontify font (entity 'tspan (char->entity (integer->char i)))))
 325
 326 (define (circle radius thick is-filled)
 327   (entity
 328    'circle ""
 329    '(stroke-linejoin . "round")
 330    '(stroke-linecap . "round")
 331    `(fill . ,(if is-filled "currentColor" "none"))
 332    `(stroke . "currentColor")
 333    `(stroke-width . ,thick)
 334    `(r . ,radius)))
 335
 336 (define (dashed-line thick on off dx dy phase)
 337   (draw-line thick 0 0 dx dy
 338              `(stroke-dasharray . ,(format #f "~a,~a" on off))))
 339
 340 (define (draw-line thick x1 y1 x2 y2 . alist)
 341   (apply entity 'line ""
 342          (append
 343           `((stroke-linejoin . "round")
 344             (stroke-linecap . "round")
 345             (stroke-width . ,thick)
 346             (stroke . "currentColor")
 347             (x1 . ,x1)
 348             (y1 . ,(- y1))
 349             (x2 . ,x2)
 350             (y2 . ,(- y2)))
 351           alist)))
 352
 353 (define (ellipse x-radius y-radius thick is-filled)
 354   (entity
 355    'ellipse ""
 356    '(stroke-linejoin . "round")
 357    '(stroke-linecap . "round")
 358    `(fill . ,(if is-filled "currentColor" "none"))
 359    `(stroke . "currentColor")
 360    `(stroke-width . ,thick)
 361    `(rx . ,x-radius)
 362    `(ry . ,y-radius)))
 363
 364 (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
 365   (define (make-ellipse-radius x-radius y-radius angle)
 366     (/ (* x-radius y-radius)
 367        (sqrt (+ (* (* y-radius y-radius)
 368                    (* (cos angle) (cos angle)))
 369                 (* (* x-radius x-radius)
 370                    (* (sin angle) (sin angle)))))))
 371   (let*
 372       ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle)))
 373        (start-radius (make-ellipse-radius x-radius y-radius new-start-angle))
 374        (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle)))
 375        (end-radius (make-ellipse-radius x-radius y-radius new-end-angle))
 376        (epsilon 1.5e-3)
 377        (x-end (- (* end-radius (cos new-end-angle))
 378                  (* start-radius (cos new-start-angle))))
 379        (y-end (- (* end-radius (sin new-end-angle))
 380                  (* start-radius (sin new-start-angle)))))
 381     (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
 382         (entity
 383          'ellipse ""
 384          `(fill . ,(if fill "currentColor" "none"))
 385          `(stroke . "currentColor")
 386          `(stroke-width . ,thick)
 387          '(stroke-linejoin . "round")
 388          '(stroke-linecap . "round")
 389          '(cx . 0)
 390          '(cy . 0)
 391          `(rx . ,x-radius)
 392          `(ry . ,y-radius))
 393         (entity
 394          'path ""
 395          `(fill . ,(if fill "currentColor" "none"))
 396          `(stroke . "currentColor")
 397          `(stroke-width . ,thick)
 398          '(stroke-linejoin . "round")
 399          '(stroke-linecap . "round")
 400          (cons
 401           'd
 402           (string-append
 403            (ly:format
 404             "M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f"
 405             (* start-radius (cos new-start-angle))
 406             (- (* start-radius (sin new-start-angle)))
 407             x-radius
 408             y-radius
 409             (if (> 0 (- new-start-angle new-end-angle)) 0 1)
 410             (* end-radius (cos new-end-angle))
 411             (- (* end-radius (sin new-end-angle))))
 412            (if connect
 413                (ly:format "L~4f,~4f"
 414                           (* start-radius (cos new-start-angle))
 415                           (- (* start-radius (sin new-start-angle))))
 416                "")))))))
 417
 418 (define (embedded-svg string)
 419   string)
 420
 421 (define (embedded-glyph-string pango-font font size cid glyphs)
 422   (define path "")
 423   (if (= 1 (length glyphs))
 424       (set! path (music-string-to-path font size (car glyphs)))
 425       (begin
 426         (set! path
 427               (string-append (eo 'g)
 428                              (string-join
 429                               (map (lambda (x)
 430                                      (music-string-to-path font size x))
 431                                    glyphs)
 432                               "\n")
 433                              (ec 'g)))))
 434   (set! next-horiz-adv 0.0)
 435   path)
 436
 437 (define (woff-glyph-string pango-font font-name size cid? w-h-x-y-named-glyphs)
 438   (let* ((name-style (font-name-style font-name))
 439          (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)")
 440                                          font-name))
 441          (family (if (regexp-match? family-designsize)
 442                      (match:substring family-designsize 1)
 443                      font-name))
 444          (design-size (if (regexp-match? family-designsize)
 445                           (match:substring family-designsize 2)
 446                           #f))
 447          (scaled-size (/ size lily-unit-length))
 448          (font (ly:paper-get-font paper `(((font-family . ,family)
 449                                            ,(if design-size
 450                                                 `(design-size . design-size)))))))
 451     (define (glyph-spec w h x y g) ; h not used
 452       (let* ((charcode (ly:font-glyph-name-to-charcode font g))
 453              (char-lookup (format #f "&#~S;" charcode))
 454              (glyph-by-name (eoc 'altglyph `(glyphname . ,g)))
 455              (apparently-broken
 456               (comment "XFIXME: how to select glyph by name, altglyph is broken?")))
 457         ;; what is W?
 458         (ly:format
 459          "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>"
 460          (if (or (> (abs x) 0.00001)
 461                  (> (abs y) 0.00001))
 462              (ly:format " transform=\"translate(~4f,~4f)\"" x y)
 463              " ")
 464          name-style scaled-size
 465          (string-regexp-substitute
 466           "\n" ""
 467           (string-append glyph-by-name apparently-broken char-lookup)))))
 468
 469     (string-join (map (lambda (x) (apply glyph-spec x))
 470                       (reverse w-h-x-y-named-glyphs)) "\n")))
 471
 472 (define glyph-string
 473   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 474
 475 (define (grob-cause offset grob)
 476   (and (ly:get-option 'point-and-click)
 477        (let* ((cause (ly:grob-property grob 'cause))
 478               (music-origin (if (ly:stream-event? cause)
 479                                 (ly:event-property cause 'origin)))
 480               (point-and-click (ly:get-option 'point-and-click)))
 481          (and (ly:input-location? music-origin)
 482               (cond ((boolean? point-and-click) point-and-click)
 483                     ((symbol? point-and-click)
 484                      (ly:in-event-class? cause point-and-click))
 485                     (else (any (lambda (t)
 486                                  (ly:in-event-class? cause t))
 487                                point-and-click)))
 488               (let* ((location (ly:input-file-line-char-column music-origin))
 489                      (raw-file (car location))
 490                      (file (if (is-absolute? raw-file)
 491                                raw-file
 492                                (string-append (ly-getcwd) "/" raw-file))))
 493
 494                 (ly:format "<a style=\"color:inherit;\" xlink:href=\"textedit://~a:~a:~a:~a\">\n"
 495                            ;; Backslashes are not valid
 496                            ;; file URI path separators.
 497                            (ly:string-percent-encode
 498                             (ly:string-substitute "\\" "/" file))
 499
 500                            (cadr location)
 501                            (caddr location)
 502                            (1+ (cadddr location))))))))
 503
 504 (define (named-glyph font name)
 505   (fontify font name))
 506
 507 (define (no-origin) "</a>\n")
 508
 509 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
 510   (define (convert-path-exps exps)
 511     (if (pair? exps)
 512         (let*
 513             ((head (car exps))
 514              (rest (cdr exps))
 515              (arity
 516               (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 517                     ((memq head '(rcurveto curveto)) 6)
 518                     ((eq? head 'closepath) 0)
 519                     (else 1)))
 520              (args (take rest arity))
 521              (svg-head (assoc-get head
 522                                   '((rmoveto . m)
 523                                     (rcurveto . c)
 524                                     (curveto . C)
 525                                     (moveto . M)
 526                                     (lineto . L)
 527                                     (rlineto . l)
 528                                     (closepath . z))
 529                                   "")))
 530
 531           (cons (format #f "~a~a" svg-head (number-list->point args))
 532                 (convert-path-exps (drop rest arity))))
 533         '()))
 534
 535   (let* ((line-cap-styles '(butt round square))
 536          (line-join-styles '(miter round bevel))
 537          (cap-style (if (not (memv cap line-cap-styles))
 538                         (begin
 539                           (ly:warning (_ "unknown line-cap-style: ~S")
 540                                       (symbol->string cap))
 541                           'round)
 542                         cap))
 543          (join-style (if (not (memv join line-join-styles))
 544                          (begin
 545                            (ly:warning (_ "unknown line-join-style: ~S")
 546                                        (symbol->string join))
 547                            'round)
 548                          join)))
 549     (entity 'path ""
 550             `(stroke-width . ,thick)
 551             `(stroke-linejoin . ,(symbol->string join-style))
 552             `(stroke-linecap . ,(symbol->string cap-style))
 553             '(stroke . "currentColor")
 554             `(fill . ,(if fill? "currentColor" "none"))
 555             `(d . ,(string-concatenate (convert-path-exps commands))))))
 556
 557 (define (placebox x y expr)
 558   (if (string-null? expr)
 559       ""
 560       (let*
 561           ((normal-element (regexp-exec svg-element-regexp expr))
 562            (scaled-element (regexp-exec scaled-element-regexp expr))
 563            (scaled? (if scaled-element #t #f))
 564            (match (if scaled? scaled-element normal-element))
 565            (string1 (match:substring match 1))
 566            (string2 (match:substring match 2)))
 567
 568         (if scaled?
 569             (string-append string1
 570                            (ly:format "translate(~4f, ~4f) " x (- y))
 571                            string2
 572                            "\n")
 573             (string-append string1
 574                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 575                                       x (- y))
 576                            string2
 577                            "\n")))))
 578
 579 (define (polygon coords blot-diameter is-filled)
 580   (entity
 581    'polygon ""
 582    '(stroke-linejoin . "round")
 583    '(stroke-linecap . "round")
 584    `(stroke-width . ,blot-diameter)
 585    `(fill . ,(if is-filled "currentColor" "none"))
 586    '(stroke . "currentColor")
 587    `(points . ,(string-join
 588                 (map offset->point (ly:list->offsets '() coords))))))
 589
 590 (define (resetcolor)
 591   "</g>\n")
 592
 593 (define (resetrotation ang x y)
 594   "</g>\n")
 595
 596 (define (resetscale)
 597   "</g>\n")
 598
 599 (define (round-filled-box breapth width depth height blot-diameter)
 600   (entity
 601    'rect ""
 602    ;; The stroke will stick out.  To use stroke,
 603    ;; the stroke-width must be subtracted from all other dimensions.
 604    ;;'(stroke-linejoin . "round")
 605    ;;'(stroke-linecap . "round")
 606    ;;`(stroke-width . ,blot)
 607    ;;'(stroke . "red")
 608    ;;'(fill . "orange")
 609
 610    `(x . ,(- breapth))
 611    `(y . ,(- height))
 612    `(width . ,(+ breapth width))
 613    `(height . ,(+ depth height))
 614    `(ry . ,(/ blot-diameter 2))
 615    '(fill . "currentColor")))
 616
 617 (define (setcolor r g b)
 618   (format #f "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
 619           (* 100 r) (* 100 g) (* 100 b)))
 620
 621 ;; rotate around given point
 622 (define (setrotation ang x y)
 623   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
 624              (- ang) x (- y)))
 625
 626 (define (setscale x y)
 627   (ly:format "<g transform=\"scale(~4f, ~4f)\">\n"
 628              x y))
 629
 630 (define (text font string)
 631   (fontify font (entity 'tspan (string->entities string))))
 632
 633 (define (url-link url x y)
 634   (string-append
 635    (eo 'a `(xlink:href . ,url))
 636    (eoc 'rect
 637         `(x . ,(car x))
 638         `(y . ,(car y))
 639         `(width . ,(- (cdr x) (car x)))
 640         `(height . ,(- (cdr y) (car y)))
 641         '(fill . "none")
 642         '(stroke . "none")
 643         '(stroke-width . "0.0"))
 644    (ec 'a)))
 645
 646 (define (utf-8-string pango-font-description string)
 647   (let ((escaped-string (string-regexp-substitute
 648                          "<" "&lt;"
 649                          (string-regexp-substitute "&" "&amp;" string))))
 650     (fontify pango-font-description
 651              (entity 'tspan escaped-string))))