scm/output-svg.scm

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