scm/output-svg.scm

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