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 (use-modules
  23   (guile)
  24   (ice-9 regex)
  25   (ice-9 format)
  26   (lily)
  27   (srfi srfi-1)
  28   (srfi srfi-13))
  29
  30 (define fancy-format format)
  31 (define format ergonomic-simple-format)
  32
  33 (define lily-unit-length 1.7573)
  34
  35 (define (dispatch expr)
  36   (let ((keyword (car expr)))
  37     (cond ((eq? keyword 'some-func) "")
  38           (else (if (module-defined? this-module keyword)
  39                     (apply (eval keyword this-module) (cdr expr))
  40                     (begin (ly:warning (_ "undefined: ~S") keyword)
  41                            ""))))))
  42
  43 ;; Helper functions
  44 (define-public (attributes attributes-alist)
  45   (apply string-append
  46          (map (lambda (x)
  47                 (let ((attr (car x))
  48                       (value (cdr x)))
  49                   (if (number? value)
  50                       (set! value (ly:format "~4f" value)))
  51                   (format " ~s=\"~a\"" attr value)))
  52               attributes-alist)))
  53
  54 (define-public (eo entity . attributes-alist)
  55   "o = open"
  56   (format "<~S~a>\n" entity (attributes attributes-alist)))
  57
  58 (define-public (eoc entity . attributes-alist)
  59   " oc = open/close"
  60   (format "<~S~a/>\n" entity (attributes attributes-alist)))
  61
  62 (define-public (ec entity)
  63   "c = close"
  64   (format "</~S>\n" entity))
  65
  66 (define-public (comment s)
  67   (string-append "<!-- " s " -->\n"))
  68
  69 (define-public (entity entity string . attributes-alist)
  70   (if (equal? string "")
  71       (apply eoc entity attributes-alist)
  72       (string-append
  73         (apply eo (cons entity attributes-alist)) string (ec entity))))
  74
  75 (define (offset->point o)
  76   (ly:format "~4f ~4f" (car o) (- (cdr o))))
  77
  78 (define (number-list->point lst)
  79   (define (helper lst)
  80     (if (null? lst)
  81         '()
  82         (cons (format "~S ~S" (car lst) (- (cadr lst)))
  83               (helper (cddr lst)))))
  84
  85   (string-join (helper lst) " "))
  86
  87
  88 (define (svg-bezier lst close)
  89   (let* ((c0 (car (list-tail lst 3)))
  90          (c123 (list-head lst 3)))
  91     (string-append
  92       (if (not close) "M" "L")
  93       (offset->point c0)
  94       "C" (string-join (map offset->point c123) " ")
  95       (if (not close) "" "z"))))
  96
  97 (define (sqr x)
  98   (* x x))
  99
 100 (define (integer->entity integer)
 101   (fancy-format "&#x~x;" integer))
 102
 103 (define (char->entity char)
 104   (integer->entity (char->integer char)))
 105
 106 (define (string->entities string)
 107   (apply string-append
 108          (map (lambda (x) (char->entity x)) (string->list string))))
 109
 110 (define svg-element-regexp
 111   (make-regexp "^(<[a-z]+) ?(.*>)"))
 112
 113 (define scaled-element-regexp
 114   (make-regexp "^(<[a-z]+ transform=\")(scale.[-0-9. ]+,[-0-9. ]+.\" .*>)"))
 115
 116 (define pango-description-regexp-comma
 117   (make-regexp ",( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 118
 119 (define pango-description-regexp-nocomma
 120   (make-regexp "( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 121
 122 (define (pango-description-to-text str expr)
 123   (define alist '())
 124   (define (set-attribute attr val)
 125     (set! alist (assoc-set! alist attr val)))
 126   (let* ((match-1 (regexp-exec pango-description-regexp-comma str))
 127          (match-2 (regexp-exec pango-description-regexp-nocomma str))
 128          (match (if match-1 match-1 match-2)))
 129
 130     (if (regexp-match? match)
 131         (begin
 132           (set-attribute 'font-family (match:prefix match))
 133           (if (string? (match:substring match 1))
 134               (set-attribute 'font-weight "bold"))
 135           (if (string? (match:substring match 2))
 136               (set-attribute 'font-style "italic"))
 137           (if (string? (match:substring match 3))
 138               (set-attribute 'font-variant "small-caps"))
 139           (set-attribute 'font-size
 140                          (/ (string->number (match:substring match 4))
 141                             lily-unit-length))
 142           (set-attribute 'text-anchor "start")
 143           (set-attribute 'fill "currentColor"))
 144         (ly:warning (_ "cannot decypher Pango description: ~a") str))
 145
 146     (apply entity 'text expr (reverse! alist))))
 147
 148 (define (dump-path path scale . rest)
 149   (define alist '())
 150   (define (set-attribute attr val)
 151     (set! alist (assoc-set! alist attr val)))
 152   (if (not (null? rest))
 153       (let* ((dx (car rest))
 154              (dy (cadr rest))
 155              (total-x (+ dx next-horiz-adv)))
 156         (if (or (not (zero? total-x))
 157                 (not (zero? dy)))
 158             (let ((x (ly:format "~4f" total-x))
 159                   (y (ly:format "~4f" dy)))
 160               (set-attribute 'transform
 161                              (string-append
 162                                "translate(" x ", " y ") "
 163                                "scale(" scale ", -" scale ")")))
 164             (set-attribute 'transform
 165                            (string-append
 166                              "scale(" scale ", -" scale ")"))))
 167       (set-attribute 'transform (string-append
 168                                   "scale(" scale ", -" scale ")")))
 169
 170   (set-attribute 'd path)
 171   (set-attribute 'fill "currentColor")
 172   (apply entity 'path "" (reverse alist)))
 173
 174
 175 ;; A global variable for keeping track of the *cumulative*
 176 ;; horizontal advance for glyph strings, but only if there
 177 ;; is more than one glyph.
 178 (define next-horiz-adv 0.0)
 179
 180 ;; Matches the required "unicode" attribute from <glyph>
 181 (define glyph-unicode-value-regexp
 182   (make-regexp "unicode=\"([^\"]+)\""))
 183
 184 ;; Matches the optional path data from <glyph>
 185 (define glyph-path-regexp
 186   (make-regexp "d=\"([-MmZzLlHhVvCcSsQqTt0-9.\n ]*)\""))
 187
 188 ;; Matches a complete <glyph> element with the glyph-name
 189 ;; attribute value of NAME.  For example:
 190 ;;
 191 ;; <glyph glyph-name="period" unicode="." horiz-adv-x="110"
 192 ;; d="M0 55c0 30 25 55 55 55s55 -25 55
 193 ;; -55s-25 -55 -55 -55s-55 25 -55 55z" />
 194 ;;
 195 ;; TODO: it would be better to use an XML library to extract
 196 ;; the glyphs instead, and store them in a hash table.  --pmccarty
 197 ;;
 198 (define (glyph-element-regexp name)
 199   (make-regexp (string-append "<glyph"
 200                               "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
 201                               "[[:space:]]+glyph-name=\"("
 202                               name
 203                               ")\""
 204                               "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
 205                               "([[:space:]]+)?"
 206                               "/>")))
 207
 208 (define (extract-glyph all-glyphs name size . rest)
 209   (let* ((new-name (regexp-quote name))
 210          (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
 211          (glyph (match:substring regexp))
 212          (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
 213          (unicode-attr-value (match:substring unicode-attr 1))
 214          (unicode-attr? (regexp-match? unicode-attr))
 215          (d-attr (regexp-exec glyph-path-regexp glyph))
 216          (d-attr-value "")
 217          (d-attr? (regexp-match? d-attr))
 218          ;; TODO: not urgent, but do not hardcode this value
 219          (units-per-em 1000)
 220          (font-scale (ly:format "~4f" (/ size units-per-em)))
 221          (path ""))
 222
 223     (if (and unicode-attr? (not unicode-attr-value))
 224         (ly:warning (_ "Glyph must have a unicode value")))
 225
 226     (if d-attr? (set! d-attr-value (match:substring d-attr 1)))
 227
 228     (cond (
 229            ;; Glyph-strings with path data
 230            (and d-attr? (not (null? rest)))
 231            (begin
 232              (set! path (apply dump-path d-attr-value
 233                                          font-scale
 234                                          (list (cadr rest) (caddr rest))))
 235              (set! next-horiz-adv (+ next-horiz-adv
 236                                      (car rest)))
 237              path))
 238           ;; Glyph-strings without path data ("space")
 239           ((and (not d-attr?) (not (null? rest)))
 240            (begin
 241              (set! next-horiz-adv (+ next-horiz-adv
 242                                      (car rest)))
 243              ""))
 244           ;; Font smobs with path data
 245           ((and d-attr? (null? rest))
 246             (set! path (dump-path d-attr-value font-scale))
 247             path)
 248           ;; Font smobs without path data ("space")
 249           (else
 250             ""))))
 251
 252 (define (extract-glyph-info all-glyphs glyph size)
 253   (let* ((offsets (list-head glyph 3))
 254          (glyph-name (car (reverse glyph))))
 255     (apply extract-glyph all-glyphs glyph-name size offsets)))
 256
 257 (define (svg-defs svg-font)
 258   (let ((start (string-contains svg-font "<defs>"))
 259         (end (string-contains svg-font "</defs>")))
 260     (substring svg-font (+ start 7) (- end 1))))
 261
 262 (define (cache-font svg-font size glyph)
 263   (let ((all-glyphs (svg-defs (cached-file-contents svg-font))))
 264     (if (list? glyph)
 265         (extract-glyph-info all-glyphs glyph size)
 266         (extract-glyph all-glyphs glyph size))))
 267
 268
 269 (define (feta-alphabet-to-path font size glyph)
 270   (let* ((name-style (font-name-style font))
 271          (scaled-size (/ size lily-unit-length))
 272          (font-file (ly:find-file (string-append name-style ".svg"))))
 273
 274     (if font-file
 275         (cache-font font-file scaled-size glyph)
 276         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 277
 278
 279 (define (font-smob-to-path font glyph)
 280   (let* ((name-style (font-name-style font))
 281          (scaled-size (modified-font-metric-font-scaling font))
 282          (font-file (ly:find-file (string-append name-style ".svg"))))
 283
 284     (if font-file
 285         (cache-font font-file scaled-size glyph)
 286         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 287
 288
 289 (define (fontify font expr)
 290   (if (string? font)
 291       (pango-description-to-text font expr)
 292       (font-smob-to-path font expr)))
 293
 294 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 295 ;;; stencil outputters
 296 ;;;
 297
 298 (define (bezier-sandwich lst thick)
 299   (let* ((first (list-tail lst 4))
 300          (second (list-head lst 4)))
 301     (entity 'path ""
 302             '(stroke-linejoin . "round")
 303             '(stroke-linecap . "round")
 304             '(stroke . "currentColor")
 305             '(fill . "currentColor")
 306             `(stroke-width . ,thick)
 307             `(d . ,(string-append (svg-bezier first #f)
 308                                   (svg-bezier second #t))))))
 309
 310 (define (char font i)
 311   (dispatch
 312    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 313
 314 (define (circle radius thick is-filled)
 315   (entity
 316     'circle ""
 317     '(stroke-linejoin . "round")
 318     '(stroke-linecap . "round")
 319     `(fill . ,(if is-filled "currentColor" "none"))
 320     `(stroke . "currentColor")
 321     `(stroke-width . ,thick)
 322     `(r . ,radius)))
 323
 324 (define (dashed-line thick on off dx dy phase)
 325   (draw-line thick 0 0 dx dy
 326              `(stroke-dasharray . ,(format "~a,~a" on off))))
 327
 328 (define (draw-line thick x1 y1 x2 y2 . alist)
 329   (apply entity 'line ""
 330          (append
 331            `((stroke-linejoin . "round")
 332              (stroke-linecap . "round")
 333              (stroke-width . ,thick)
 334              (stroke . "currentColor")
 335              (x1 . ,x1)
 336              (y1 . ,(- y1))
 337              (x2 . ,x2)
 338              (y2 . ,(- y2)))
 339            alist)))
 340
 341 (define (ellipse x-radius y-radius thick is-filled)
 342   (entity
 343     'ellipse ""
 344     '(stroke-linejoin . "round")
 345     '(stroke-linecap . "round")
 346     `(fill . ,(if is-filled "currentColor" "none"))
 347     `(stroke . "currentColor")
 348     `(stroke-width . ,thick)
 349     `(rx . ,x-radius)
 350     `(ry . ,y-radius)))
 351
 352 (define (embedded-svg string)
 353   string)
 354
 355 (define (glyph-string font size cid glyphs)
 356   (define path "")
 357   (if (= 1 (length glyphs))
 358       (set! path (feta-alphabet-to-path font size (car glyphs)))
 359       (begin
 360         (set! path
 361               (string-append (eo 'g)
 362                              (string-join
 363                                (map (lambda (x)
 364                                       (feta-alphabet-to-path font size x))
 365                                     glyphs)
 366                                "\n")
 367                              (ec 'g)))))
 368   (set! next-horiz-adv 0.0)
 369   path)
 370
 371 (define (grob-cause offset grob)
 372   "")
 373
 374 (define (named-glyph font name)
 375   (dispatch `(fontify ,font ,name)))
 376
 377 (define (no-origin)
 378   "")
 379
 380 (define (oval x-radius y-radius thick is-filled)
 381   (let ((x-max x-radius)
 382         (x-min (- x-radius))
 383         (y-max y-radius)
 384         (y-min (- y-radius)))
 385     (entity
 386       'path ""
 387       '(stroke-linejoin . "round")
 388       '(stroke-linecap . "round")
 389       `(fill . ,(if is-filled "currentColor" "none"))
 390       `(stroke . "currentColor")
 391       `(stroke-width . ,thick)
 392       `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz"
 393                         x-max 0
 394                         x-max y-max
 395                         x-min y-max
 396                         x-min 0
 397                         x-max y-min
 398                         x-max 0)))))
 399
 400 (define (path thick commands)
 401   (define (convert-path-exps exps)
 402     (if (pair? exps)
 403         (let*
 404           ((head (car exps))
 405            (rest (cdr exps))
 406            (arity
 407              (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 408                    ((memq head '(rcurveto curveto)) 6)
 409                    ((eq? head 'closepath) 0)
 410                    (else 1)))
 411            (args (take rest arity))
 412            (svg-head (assoc-get head
 413                                 '((rmoveto . m)
 414                                   (rcurveto . c)
 415                                   (curveto . C)
 416                                   (moveto . M)
 417                                   (lineto . L)
 418                                   (rlineto . l)
 419                                   (closepath . z))
 420                                 "")))
 421
 422           (cons (format "~a~a" svg-head (number-list->point args))
 423                 (convert-path-exps (drop rest arity))))
 424         '()))
 425
 426   (entity 'path ""
 427           `(stroke-width . ,thick)
 428           '(stroke-linejoin . "round")
 429           '(stroke-linecap . "round")
 430           '(stroke . "currentColor")
 431           '(fill . "none")
 432           `(d . ,(apply string-append (convert-path-exps commands)))))
 433
 434 (define (placebox x y expr)
 435   (if (string-null? expr)
 436       ""
 437       (let*
 438         ((normal-element (regexp-exec svg-element-regexp expr))
 439          (scaled-element (regexp-exec scaled-element-regexp expr))
 440          (scaled? (if scaled-element #t #f))
 441          (match (if scaled? scaled-element normal-element))
 442          (string1 (match:substring match 1))
 443          (string2 (match:substring match 2)))
 444
 445         (if scaled?
 446             (string-append string1
 447                            (ly:format "translate(~4f, ~4f) " x (- y))
 448                            string2
 449                            "\n")
 450             (string-append string1
 451                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 452                                       x (- y))
 453                            string2
 454                            "\n")))))
 455
 456 (define (polygon coords blot-diameter is-filled)
 457   (entity
 458     'polygon ""
 459     '(stroke-linejoin . "round")
 460     '(stroke-linecap . "round")
 461     `(stroke-width . ,blot-diameter)
 462     `(fill . ,(if is-filled "currentColor" "none"))
 463     '(stroke . "currentColor")
 464     `(points . ,(string-join
 465                   (map offset->point (ly:list->offsets '() coords))))))
 466
 467 (define (repeat-slash width slope thickness)
 468   (define (euclidean-length x y)
 469     (sqrt (+ (* x x) (* y y))))
 470   (let* ((x-width (euclidean-length thickness (/ thickness slope)))
 471          (height (* width slope)))
 472     (entity
 473       'path ""
 474       '(fill . "currentColor")
 475       `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z"
 476                         x-width width (- height) (- x-width))))))
 477
 478 (define (resetcolor)
 479   "</g>\n")
 480
 481 (define (resetrotation ang x y)
 482   "</g>\n")
 483
 484 (define (round-filled-box breapth width depth height blot-diameter)
 485   (entity
 486     'rect ""
 487     ;; The stroke will stick out.  To use stroke,
 488     ;; the stroke-width must be subtracted from all other dimensions.
 489     ;;'(stroke-linejoin . "round")
 490     ;;'(stroke-linecap . "round")
 491     ;;`(stroke-width . ,blot)
 492     ;;'(stroke . "red")
 493     ;;'(fill . "orange")
 494
 495     `(x . ,(- breapth))
 496     `(y . ,(- height))
 497     `(width . ,(+ breapth width))
 498     `(height . ,(+ depth height))
 499     `(ry . ,(/ blot-diameter 2))
 500     '(fill . "currentColor")))
 501
 502 (define (setcolor r g b)
 503   (format "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
 504           (* 100 r) (* 100 g) (* 100 b)))
 505
 506 ;; rotate around given point
 507 (define (setrotation ang x y)
 508   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
 509              (- ang) x (- y)))
 510
 511 (define (text font string)
 512   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 513
 514 (define (url-link url x y)
 515   (string-append
 516    (eo 'a `(xlink:href . ,url))
 517    (eoc 'rect
 518         `(x . ,(car x))
 519         `(y . ,(car y))
 520         `(width . ,(- (cdr x) (car x)))
 521         `(height . ,(- (cdr y) (car y)))
 522         '(fill . "none")
 523         '(stroke . "none")
 524         '(stroke-width . "0.0"))
 525    (ec 'a)))
 526
 527 (define (utf-8-string pango-font-description string)
 528   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))