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