scm/output-svg.scm

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