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 (bezier-sandwich lst thick)
 333   (let* ((first (list-tail lst 4))
 334          (second (list-head lst 4)))
 335     (entity 'path ""
 336             '(stroke-linejoin . "round")
 337             '(stroke-linecap . "round")
 338             '(stroke . "currentColor")
 339             '(fill . "currentColor")
 340             `(stroke-width . ,thick)
 341             `(d . ,(string-append (svg-bezier first #f)
 342                                   (svg-bezier second #t))))))
 343
 344 (define (char font i)
 345   (dispatch
 346    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 347
 348 (define (circle radius thick is-filled)
 349   (entity
 350     'circle ""
 351     '(stroke-linejoin . "round")
 352     '(stroke-linecap . "round")
 353     `(fill . ,(if is-filled "currentColor" "none"))
 354     `(stroke . "currentColor")
 355     `(stroke-width . ,thick)
 356     `(r . ,radius)))
 357
 358 (define (dashed-line thick on off dx dy phase)
 359   (draw-line thick 0 0 dx dy
 360              `(stroke-dasharray . ,(format #f "~a,~a" on off))))
 361
 362 (define (draw-line thick x1 y1 x2 y2 . alist)
 363   (apply entity 'line ""
 364          (append
 365            `((stroke-linejoin . "round")
 366              (stroke-linecap . "round")
 367              (stroke-width . ,thick)
 368              (stroke . "currentColor")
 369              (x1 . ,x1)
 370              (y1 . ,(- y1))
 371              (x2 . ,x2)
 372              (y2 . ,(- y2)))
 373            alist)))
 374
 375 (define (ellipse x-radius y-radius thick is-filled)
 376   (entity
 377     'ellipse ""
 378     '(stroke-linejoin . "round")
 379     '(stroke-linecap . "round")
 380     `(fill . ,(if is-filled "currentColor" "none"))
 381     `(stroke . "currentColor")
 382     `(stroke-width . ,thick)
 383     `(rx . ,x-radius)
 384     `(ry . ,y-radius)))
 385
 386 (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
 387   (define (make-ellipse-radius x-radius y-radius angle)
 388     (/ (* x-radius y-radius)
 389        (sqrt (+ (* (* y-radius y-radius)
 390                    (* (cos angle) (cos angle)))
 391                 (* (* x-radius x-radius)
 392                    (* (sin angle) (sin angle)))))))
 393   (let*
 394     ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle)))
 395      (start-radius (make-ellipse-radius x-radius y-radius new-start-angle))
 396      (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle)))
 397      (end-radius (make-ellipse-radius x-radius y-radius new-end-angle))
 398      (epsilon 1.5e-3)
 399      (x-end (- (* end-radius (cos new-end-angle))
 400                (* start-radius (cos new-start-angle))))
 401      (y-end (- (* end-radius (sin new-end-angle))
 402                (* start-radius (sin new-start-angle)))))
 403    (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
 404     (entity
 405       'ellipse ""
 406       `(fill . ,(if fill "currentColor" "none"))
 407       `(stroke . "currentColor")
 408       `(stroke-width . ,thick)
 409       '(stroke-linejoin . "round")
 410       '(stroke-linecap . "round")
 411       '(cx . 0)
 412       '(cy . 0)
 413       `(rx . ,x-radius)
 414       `(ry . ,y-radius))
 415     (entity
 416       'path ""
 417       `(fill . ,(if fill "currentColor" "none"))
 418       `(stroke . "currentColor")
 419       `(stroke-width . ,thick)
 420       '(stroke-linejoin . "round")
 421       '(stroke-linecap . "round")
 422       (cons
 423         'd
 424         (string-append
 425           (ly:format
 426             "M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f"
 427             (* start-radius (cos new-start-angle))
 428             (- (* start-radius (sin new-start-angle)))
 429             x-radius
 430             y-radius
 431             (if (> 0 (- new-start-angle new-end-angle)) 0 1)
 432             (* end-radius (cos new-end-angle))
 433             (- (* end-radius (sin new-end-angle))))
 434             (if connect
 435                 (ly:format "L~4f,~4f"
 436                            (* start-radius (cos new-start-angle))
 437                            (- (* start-radius (sin new-start-angle))))
 438                 "")))))))
 439
 440 (define (embedded-svg string)
 441   string)
 442
 443 (define (embedded-glyph-string font size cid glyphs)
 444   (define path "")
 445   (if (= 1 (length glyphs))
 446       (set! path (music-string-to-path font size (car glyphs)))
 447       (begin
 448         (set! path
 449               (string-append (eo 'g)
 450                              (string-join
 451                                (map (lambda (x)
 452                                       (music-string-to-path font size x))
 453                                     glyphs)
 454                                "\n")
 455                              (ec 'g)))))
 456   (set! next-horiz-adv 0.0)
 457   path)
 458
 459 (define (woff-glyph-string font-name size cid? w-x-y-named-glyphs)
 460   (let* ((name-style (font-name-style font-name))
 461          (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)")
 462                                          font-name))
 463          (family (if (regexp-match? family-designsize)
 464                      (match:substring family-designsize 1)
 465                      font-name))
 466          (design-size (if (regexp-match? family-designsize)
 467                           (match:substring family-designsize 2)
 468                           #f))
 469          (scaled-size (/ size lily-unit-length))
 470          (font (ly:paper-get-font paper `(((font-family . ,family)
 471                                            ,(if design-size
 472                                                 `(design-size . design-size)))))))
 473     (define (glyph-spec w x y g)
 474       (let* ((charcode (ly:font-glyph-name-to-charcode font g))
 475              (char-lookup (format #f "&#~S;" charcode))
 476              (glyph-by-name (eoc 'altglyph `(glyphname . ,g)))
 477              (apparently-broken
 478               (comment "XFIXME: how to select glyph by name, altglyph is broken?")))
 479         ;; what is W?
 480         (ly:format
 481          "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>"
 482          (if (or (> (abs x) 0.00001)
 483                  (> (abs y) 0.00001))
 484              (ly:format " transform=\"translate(~4f,~4f)\"" x y)
 485              " ")
 486          name-style scaled-size
 487          (string-regexp-substitute
 488           "\n" ""
 489           (string-append glyph-by-name apparently-broken char-lookup)))))
 490
 491     (string-join (map (lambda (x) (apply glyph-spec x))
 492                       (reverse w-x-y-named-glyphs)) "\n")))
 493
 494 (define glyph-string
 495   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 496
 497 (define (grob-cause offset grob)
 498   "")
 499
 500 (define (named-glyph font name)
 501   (dispatch `(fontify ,font ,name)))
 502
 503 (define (no-origin)
 504   "")
 505
 506 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
 507   (define (convert-path-exps exps)
 508     (if (pair? exps)
 509         (let*
 510           ((head (car exps))
 511            (rest (cdr exps))
 512            (arity
 513              (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 514                    ((memq head '(rcurveto curveto)) 6)
 515                    ((eq? head 'closepath) 0)
 516                    (else 1)))
 517            (args (take rest arity))
 518            (svg-head (assoc-get head
 519                                 '((rmoveto . m)
 520                                   (rcurveto . c)
 521                                   (curveto . C)
 522                                   (moveto . M)
 523                                   (lineto . L)
 524                                   (rlineto . l)
 525                                   (closepath . z))
 526                                 "")))
 527
 528           (cons (format #f "~a~a" svg-head (number-list->point args))
 529                 (convert-path-exps (drop rest arity))))
 530         '()))
 531
 532   (let* ((line-cap-styles '(butt round square))
 533          (line-join-styles '(miter round bevel))
 534          (cap-style (if (not (memv cap line-cap-styles))
 535                         (begin
 536                           (ly:warning (_ "unknown line-cap-style: ~S")
 537                                       (symbol->string cap))
 538                           'round)
 539                         cap))
 540          (join-style (if (not (memv join line-join-styles))
 541                          (begin
 542                            (ly:warning (_ "unknown line-join-style: ~S")
 543                                        (symbol->string join))
 544                            'round)
 545                          join)))
 546     (entity 'path ""
 547             `(stroke-width . ,thick)
 548             `(stroke-linejoin . ,(symbol->string join-style))
 549             `(stroke-linecap . ,(symbol->string cap-style))
 550             '(stroke . "currentColor")
 551             `(fill . ,(if fill? "currentColor" "none"))
 552             `(d . ,(apply string-append (convert-path-exps commands))))))
 553
 554 (define (placebox x y expr)
 555   (if (string-null? expr)
 556       ""
 557       (let*
 558         ((normal-element (regexp-exec svg-element-regexp expr))
 559          (scaled-element (regexp-exec scaled-element-regexp expr))
 560          (scaled? (if scaled-element #t #f))
 561          (match (if scaled? scaled-element normal-element))
 562          (string1 (match:substring match 1))
 563          (string2 (match:substring match 2)))
 564
 565         (if scaled?
 566             (string-append string1
 567                            (ly:format "translate(~4f, ~4f) " x (- y))
 568                            string2
 569                            "\n")
 570             (string-append string1
 571                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 572                                       x (- y))
 573                            string2
 574                            "\n")))))
 575
 576 (define (polygon coords blot-diameter is-filled)
 577   (entity
 578     'polygon ""
 579     '(stroke-linejoin . "round")
 580     '(stroke-linecap . "round")
 581     `(stroke-width . ,blot-diameter)
 582     `(fill . ,(if is-filled "currentColor" "none"))
 583     '(stroke . "currentColor")
 584     `(points . ,(string-join
 585                   (map offset->point (ly:list->offsets '() coords))))))
 586
 587 (define (repeat-slash width slope thickness)
 588   (define (euclidean-length x y)
 589     (sqrt (+ (* x x) (* y y))))
 590   (let* ((x-width (euclidean-length thickness (/ thickness slope)))
 591          (height (* width slope)))
 592     (entity
 593       'path ""
 594       '(fill . "currentColor")
 595       `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z"
 596                         x-width width (- height) (- x-width))))))
 597
 598 (define (resetcolor)
 599   "</g>\n")
 600
 601 (define (resetrotation ang x y)
 602   "</g>\n")
 603
 604 (define (resetscale)
 605   "</g>\n")
 606
 607 (define (round-filled-box breapth width depth height blot-diameter)
 608   (entity
 609     'rect ""
 610     ;; The stroke will stick out.  To use stroke,
 611     ;; the stroke-width must be subtracted from all other dimensions.
 612     ;;'(stroke-linejoin . "round")
 613     ;;'(stroke-linecap . "round")
 614     ;;`(stroke-width . ,blot)
 615     ;;'(stroke . "red")
 616     ;;'(fill . "orange")
 617
 618     `(x . ,(- breapth))
 619     `(y . ,(- height))
 620     `(width . ,(+ breapth width))
 621     `(height . ,(+ depth height))
 622     `(ry . ,(/ blot-diameter 2))
 623     '(fill . "currentColor")))
 624
 625 (define (setcolor r g b)
 626   (format #f "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
 627           (* 100 r) (* 100 g) (* 100 b)))
 628
 629 ;; rotate around given point
 630 (define (setrotation ang x y)
 631   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
 632              (- ang) x (- y)))
 633
 634 (define (setscale x y)
 635   (ly:format "<g transform=\"scale(~4f, ~4f)\">\n"
 636              x y))
 637
 638 (define (text font string)
 639   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 640
 641 (define (url-link url x y)
 642   (string-append
 643    (eo 'a `(xlink:href . ,url))
 644    (eoc 'rect
 645         `(x . ,(car x))
 646         `(y . ,(car y))
 647         `(width . ,(- (cdr x) (car x)))
 648         `(height . ,(- (cdr y) (car y)))
 649         '(fill . "none")
 650         '(stroke . "none")
 651         '(stroke-width . "0.0"))
 652    (ec 'a)))
 653
 654 (define (utf-8-string pango-font-description string)
 655   (let ((escaped-string (string-regexp-substitute
 656                           "<" "&lt;"
 657                           (string-regexp-substitute "&" "&amp;" string))))
 658     (dispatch `(fontify ,pango-font-description
 659                         ,(entity 'tspan escaped-string)))))