scm/output-svg.scm

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