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     ((dummy (format #t "INFO XR ~a YR ~a SA ~a EA ~a\n" x-radius y-radius start-angle end-angle))
 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      (dummy (format #t "INFO NSA ~a SR ~a NEA ~a ER ~a\n" new-start-angle start-radius new-end-angle end-radius)))
 398    (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
 399     (entity
 400       'ellipse ""
 401       `(fill . ,(if fill "currentColor" "none"))
 402       `(stroke . "currentColor")
 403       `(stroke-width . ,thick)
 404       '(stroke-linejoin . "round")
 405       '(stroke-linecap . "round")
 406       '(cx . 0)
 407       '(cy . 0)
 408       `(rx . ,x-radius)
 409       `(ry . ,y-radius))
 410     (entity
 411       'path ""
 412       `(fill . ,(if fill "currentColor" "none"))
 413       `(stroke . "currentColor")
 414       `(stroke-width . ,thick)
 415       '(stroke-linejoin . "round")
 416       '(stroke-linecap . "round")
 417       (cons
 418         'd
 419         (string-append
 420           (ly:format
 421             "M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f"
 422             (* start-radius (cos new-start-angle))
 423             (- (* start-radius (sin new-start-angle)))
 424             x-radius
 425             y-radius
 426             (if (> 0 (- new-start-angle new-end-angle)) 0 1)
 427             (* end-radius (cos new-end-angle))
 428             (- (* end-radius (sin new-end-angle))))
 429             (if connect
 430                 (ly:format "L~4f,~4f"
 431                            (* start-radius (cos new-start-angle))
 432                            (- (* start-radius (sin new-start-angle))))
 433                 "")))))))
 434
 435 (define (connected-shape pointlist thick x-scale y-scale connect fill)
 436   (entity
 437     'path ""
 438     `(fill . ,(if fill "currentColor" "none"))
 439     `(stroke . "currentColor")
 440     `(stroke-width . ,thick)
 441     '(stroke-linejoin . "round")
 442     '(stroke-linecap . "round")
 443     (cons
 444       'd
 445       (ly:format
 446         "M0 0~a ~a"
 447         (string-concatenate
 448           (map (lambda (x)
 449                  (apply
 450                    (if (eq? (length x) 6)
 451                        (lambda (x1 x2 x3 x4 x5 x6)
 452                          (ly:format "C~4f ~4f ~4f ~4f ~4f ~4f"
 453                                     (* x1 x-scale)
 454                                     (- (* x2 y-scale))
 455                                     (* x3 x-scale)
 456                                     (- (* x4 y-scale))
 457                                     (* x5 x-scale)
 458                                     (- (* x6 y-scale))))
 459                        (lambda (x1 x2)
 460                          (ly:format "L~4f ~4f"
 461                                     (* x-scale x1)
 462                                     (- (* y-scale x2)))))
 463                    x))
 464                pointlist))
 465         (if connect "z " "")))))
 466
 467 (define (embedded-svg string)
 468   string)
 469
 470 (define (embedded-glyph-string font size cid glyphs)
 471   (define path "")
 472   (if (= 1 (length glyphs))
 473       (set! path (music-string-to-path font size (car glyphs)))
 474       (begin
 475         (set! path
 476               (string-append (eo 'g)
 477                              (string-join
 478                                (map (lambda (x)
 479                                       (music-string-to-path font size x))
 480                                     glyphs)
 481                                "\n")
 482                              (ec 'g)))))
 483   (set! next-horiz-adv 0.0)
 484   path)
 485
 486 (define (woff-glyph-string font-name size cid? w-x-y-named-glyphs)
 487   (let* ((name-style (font-name-style font-name))
 488          (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)")
 489                                          font-name))
 490          (family (if (regexp-match? family-designsize)
 491                      (match:substring family-designsize 1)
 492                      font-name))
 493          (design-size (if (regexp-match? family-designsize)
 494                           (match:substring family-designsize 2)
 495                           #f))
 496          (scaled-size (/ size lily-unit-length))
 497          (font (ly:paper-get-font paper `(((font-family . ,family)
 498                                            ,(if design-size
 499                                                 `(design-size . design-size)))))))
 500     (define (glyph-spec w x y g)
 501       (let* ((charcode (ly:font-glyph-name-to-charcode font g))
 502              (char-lookup (format #f "&#~S;" charcode))
 503              (glyph-by-name (eoc 'altglyph `(glyphname . ,g)))
 504              (apparently-broken
 505               (comment "XFIXME: how to select glyph by name, altglyph is broken?")))
 506         ;; what is W?
 507         (ly:format
 508          "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>"
 509          (if (or (> (abs x) 0.00001)
 510                  (> (abs y) 0.00001))
 511              (ly:format " transform=\"translate(~4f,~4f)\"" x y)
 512              " ")
 513          name-style scaled-size
 514          (string-regexp-substitute
 515           "\n" ""
 516           (string-append glyph-by-name apparently-broken char-lookup)))))
 517
 518     (string-join (map (lambda (x) (apply glyph-spec x))
 519                       (reverse w-x-y-named-glyphs)) "\n")))
 520
 521 (define glyph-string
 522   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 523
 524 (define (grob-cause offset grob)
 525   "")
 526
 527 (define (named-glyph font name)
 528   (dispatch `(fontify ,font ,name)))
 529
 530 (define (no-origin)
 531   "")
 532
 533 (define (oval x-radius y-radius thick is-filled)
 534   (let ((x-max x-radius)
 535         (x-min (- x-radius))
 536         (y-max y-radius)
 537         (y-min (- y-radius)))
 538     (entity
 539       'path ""
 540       '(stroke-linejoin . "round")
 541       '(stroke-linecap . "round")
 542       `(fill . ,(if is-filled "currentColor" "none"))
 543       `(stroke . "currentColor")
 544       `(stroke-width . ,thick)
 545       `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz"
 546                         x-max 0
 547                         x-max y-max
 548                         x-min y-max
 549                         x-min 0
 550                         x-max y-min
 551                         x-max 0)))))
 552
 553 (define (path thick commands)
 554   (define (convert-path-exps exps)
 555     (if (pair? exps)
 556         (let*
 557           ((head (car exps))
 558            (rest (cdr exps))
 559            (arity
 560              (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 561                    ((memq head '(rcurveto curveto)) 6)
 562                    ((eq? head 'closepath) 0)
 563                    (else 1)))
 564            (args (take rest arity))
 565            (svg-head (assoc-get head
 566                                 '((rmoveto . m)
 567                                   (rcurveto . c)
 568                                   (curveto . C)
 569                                   (moveto . M)
 570                                   (lineto . L)
 571                                   (rlineto . l)
 572                                   (closepath . z))
 573                                 "")))
 574
 575           (cons (format "~a~a" svg-head (number-list->point args))
 576                 (convert-path-exps (drop rest arity))))
 577         '()))
 578
 579   (entity 'path ""
 580           `(stroke-width . ,thick)
 581           '(stroke-linejoin . "round")
 582           '(stroke-linecap . "round")
 583           '(stroke . "currentColor")
 584           '(fill . "none")
 585           `(d . ,(apply string-append (convert-path-exps commands)))))
 586
 587 (define (placebox x y expr)
 588   (if (string-null? expr)
 589       ""
 590       (let*
 591         ((normal-element (regexp-exec svg-element-regexp expr))
 592          (scaled-element (regexp-exec scaled-element-regexp expr))
 593          (scaled? (if scaled-element #t #f))
 594          (match (if scaled? scaled-element normal-element))
 595          (string1 (match:substring match 1))
 596          (string2 (match:substring match 2)))
 597
 598         (if scaled?
 599             (string-append string1
 600                            (ly:format "translate(~4f, ~4f) " x (- y))
 601                            string2
 602                            "\n")
 603             (string-append string1
 604                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 605                                       x (- y))
 606                            string2
 607                            "\n")))))
 608
 609 (define (polygon coords blot-diameter is-filled)
 610   (entity
 611     'polygon ""
 612     '(stroke-linejoin . "round")
 613     '(stroke-linecap . "round")
 614     `(stroke-width . ,blot-diameter)
 615     `(fill . ,(if is-filled "currentColor" "none"))
 616     '(stroke . "currentColor")
 617     `(points . ,(string-join
 618                   (map offset->point (ly:list->offsets '() coords))))))
 619
 620 (define (repeat-slash width slope thickness)
 621   (define (euclidean-length x y)
 622     (sqrt (+ (* x x) (* y y))))
 623   (let* ((x-width (euclidean-length thickness (/ thickness slope)))
 624          (height (* width slope)))
 625     (entity
 626       'path ""
 627       '(fill . "currentColor")
 628       `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z"
 629                         x-width width (- height) (- x-width))))))
 630
 631 (define (resetcolor)
 632   "</g>\n")
 633
 634 (define (resetrotation ang x y)
 635   "</g>\n")
 636
 637 (define (round-filled-box breapth width depth height blot-diameter)
 638   (entity
 639     'rect ""
 640     ;; The stroke will stick out.  To use stroke,
 641     ;; the stroke-width must be subtracted from all other dimensions.
 642     ;;'(stroke-linejoin . "round")
 643     ;;'(stroke-linecap . "round")
 644     ;;`(stroke-width . ,blot)
 645     ;;'(stroke . "red")
 646     ;;'(fill . "orange")
 647
 648     `(x . ,(- breapth))
 649     `(y . ,(- height))
 650     `(width . ,(+ breapth width))
 651     `(height . ,(+ depth height))
 652     `(ry . ,(/ blot-diameter 2))
 653     '(fill . "currentColor")))
 654
 655 (define (setcolor r g b)
 656   (format "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
 657           (* 100 r) (* 100 g) (* 100 b)))
 658
 659 ;; rotate around given point
 660 (define (setrotation ang x y)
 661   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
 662              (- ang) x (- y)))
 663
 664 (define (text font string)
 665   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 666
 667 (define (url-link url x y)
 668   (string-append
 669    (eo 'a `(xlink:href . ,url))
 670    (eoc 'rect
 671         `(x . ,(car x))
 672         `(y . ,(car y))
 673         `(width . ,(- (cdr x) (car x)))
 674         `(height . ,(- (cdr y) (car y)))
 675         '(fill . "none")
 676         '(stroke . "none")
 677         '(stroke-width . "0.0"))
 678    (ec 'a)))
 679
 680 (define (utf-8-string pango-font-description string)
 681   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))