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 (music-string-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 (define embedded #f)
 289
 290 (define (woff-font-smob-to-text font expr)
 291   (let* ((name-style (font-name-style font))
 292          (scaled-size (modified-font-metric-font-scaling font))
 293          (font-file (ly:find-file (string-append name-style ".woff")))
 294          (charcode (ly:font-glyph-name-to-charcode font expr))
 295          (text (format #f "&#~S;" charcode)))
 296   (define alist '())
 297   (define (set-attribute attr val)
 298     (set! alist (assoc-set! alist attr val)))
 299   (set-attribute 'font-family name-style)
 300   (set-attribute 'font-size scaled-size)
 301   (apply entity 'text text (reverse! alist))))
 302
 303 (define font-smob-to-text
 304   (if (not (ly:get-option 'svg-woff))
 305       font-smob-to-path woff-font-smob-to-text))
 306
 307 (define (fontify font expr)
 308   (if (string? font)
 309       (pango-description-to-text font expr)
 310       (font-smob-to-text font expr)))
 311
 312 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 313 ;;; stencil outputters
 314 ;;;
 315
 316 (define (bezier-sandwich lst thick)
 317   (let* ((first (list-tail lst 4))
 318          (second (list-head lst 4)))
 319     (entity 'path ""
 320             '(stroke-linejoin . "round")
 321             '(stroke-linecap . "round")
 322             '(stroke . "currentColor")
 323             '(fill . "currentColor")
 324             `(stroke-width . ,thick)
 325             `(d . ,(string-append (svg-bezier first #f)
 326                                   (svg-bezier second #t))))))
 327
 328 (define (char font i)
 329   (dispatch
 330    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 331
 332 (define (circle radius thick is-filled)
 333   (entity
 334     'circle ""
 335     '(stroke-linejoin . "round")
 336     '(stroke-linecap . "round")
 337     `(fill . ,(if is-filled "currentColor" "none"))
 338     `(stroke . "currentColor")
 339     `(stroke-width . ,thick)
 340     `(r . ,radius)))
 341
 342 (define (dashed-line thick on off dx dy phase)
 343   (draw-line thick 0 0 dx dy
 344              `(stroke-dasharray . ,(format "~a,~a" on off))))
 345
 346 (define (draw-line thick x1 y1 x2 y2 . alist)
 347   (apply entity 'line ""
 348          (append
 349            `((stroke-linejoin . "round")
 350              (stroke-linecap . "round")
 351              (stroke-width . ,thick)
 352              (stroke . "currentColor")
 353              (x1 . ,x1)
 354              (y1 . ,(- y1))
 355              (x2 . ,x2)
 356              (y2 . ,(- y2)))
 357            alist)))
 358
 359 (define (ellipse x-radius y-radius thick is-filled)
 360   (entity
 361     'ellipse ""
 362     '(stroke-linejoin . "round")
 363     '(stroke-linecap . "round")
 364     `(fill . ,(if is-filled "currentColor" "none"))
 365     `(stroke . "currentColor")
 366     `(stroke-width . ,thick)
 367     `(rx . ,x-radius)
 368     `(ry . ,y-radius)))
 369
 370 (define (embedded-svg string)
 371   string)
 372
 373 (define (embedded-glyph-string font size cid glyphs)
 374   (define path "")
 375   (if (= 1 (length glyphs))
 376       (set! path (music-string-to-path font size (car glyphs)))
 377       (begin
 378         (set! path
 379               (string-append (eo 'g)
 380                              (string-join
 381                                (map (lambda (x)
 382                                       (music-string-to-path font size x))
 383                                     glyphs)
 384                                "\n")
 385                              (ec 'g)))))
 386   (set! next-horiz-adv 0.0)
 387   path)
 388
 389 (define (woff-glyph-string font size cid glyphs)
 390   (named-glyph font glyphs))
 391
 392 (define glyph-string
 393   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 394
 395 (define (grob-cause offset grob)
 396   "")
 397
 398 (define (named-glyph font name)
 399   (dispatch `(fontify ,font ,name)))
 400
 401 (define (no-origin)
 402   "")
 403
 404 (define (oval x-radius y-radius thick is-filled)
 405   (let ((x-max x-radius)
 406         (x-min (- x-radius))
 407         (y-max y-radius)
 408         (y-min (- y-radius)))
 409     (entity
 410       'path ""
 411       '(stroke-linejoin . "round")
 412       '(stroke-linecap . "round")
 413       `(fill . ,(if is-filled "currentColor" "none"))
 414       `(stroke . "currentColor")
 415       `(stroke-width . ,thick)
 416       `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz"
 417                         x-max 0
 418                         x-max y-max
 419                         x-min y-max
 420                         x-min 0
 421                         x-max y-min
 422                         x-max 0)))))
 423
 424 (define (path thick commands)
 425   (define (convert-path-exps exps)
 426     (if (pair? exps)
 427         (let*
 428           ((head (car exps))
 429            (rest (cdr exps))
 430            (arity
 431              (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 432                    ((memq head '(rcurveto curveto)) 6)
 433                    ((eq? head 'closepath) 0)
 434                    (else 1)))
 435            (args (take rest arity))
 436            (svg-head (assoc-get head
 437                                 '((rmoveto . m)
 438                                   (rcurveto . c)
 439                                   (curveto . C)
 440                                   (moveto . M)
 441                                   (lineto . L)
 442                                   (rlineto . l)
 443                                   (closepath . z))
 444                                 "")))
 445
 446           (cons (format "~a~a" svg-head (number-list->point args))
 447                 (convert-path-exps (drop rest arity))))
 448         '()))
 449
 450   (entity 'path ""
 451           `(stroke-width . ,thick)
 452           '(stroke-linejoin . "round")
 453           '(stroke-linecap . "round")
 454           '(stroke . "currentColor")
 455           '(fill . "none")
 456           `(d . ,(apply string-append (convert-path-exps commands)))))
 457
 458 (define (placebox x y expr)
 459   (if (string-null? expr)
 460       ""
 461       (let*
 462         ((normal-element (regexp-exec svg-element-regexp expr))
 463          (scaled-element (regexp-exec scaled-element-regexp expr))
 464          (scaled? (if scaled-element #t #f))
 465          (match (if scaled? scaled-element normal-element))
 466          (string1 (match:substring match 1))
 467          (string2 (match:substring match 2)))
 468
 469         (if scaled?
 470             (string-append string1
 471                            (ly:format "translate(~4f, ~4f) " x (- y))
 472                            string2
 473                            "\n")
 474             (string-append string1
 475                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 476                                       x (- y))
 477                            string2
 478                            "\n")))))
 479
 480 (define (polygon coords blot-diameter is-filled)
 481   (entity
 482     'polygon ""
 483     '(stroke-linejoin . "round")
 484     '(stroke-linecap . "round")
 485     `(stroke-width . ,blot-diameter)
 486     `(fill . ,(if is-filled "currentColor" "none"))
 487     '(stroke . "currentColor")
 488     `(points . ,(string-join
 489                   (map offset->point (ly:list->offsets '() coords))))))
 490
 491 (define (repeat-slash width slope thickness)
 492   (define (euclidean-length x y)
 493     (sqrt (+ (* x x) (* y y))))
 494   (let* ((x-width (euclidean-length thickness (/ thickness slope)))
 495          (height (* width slope)))
 496     (entity
 497       'path ""
 498       '(fill . "currentColor")
 499       `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z"
 500                         x-width width (- height) (- x-width))))))
 501
 502 (define (resetcolor)
 503   "</g>\n")
 504
 505 (define (resetrotation ang x y)
 506   "</g>\n")
 507
 508 (define (round-filled-box breapth width depth height blot-diameter)
 509   (entity
 510     'rect ""
 511     ;; The stroke will stick out.  To use stroke,
 512     ;; the stroke-width must be subtracted from all other dimensions.
 513     ;;'(stroke-linejoin . "round")
 514     ;;'(stroke-linecap . "round")
 515     ;;`(stroke-width . ,blot)
 516     ;;'(stroke . "red")
 517     ;;'(fill . "orange")
 518
 519     `(x . ,(- breapth))
 520     `(y . ,(- height))
 521     `(width . ,(+ breapth width))
 522     `(height . ,(+ depth height))
 523     `(ry . ,(/ blot-diameter 2))
 524     '(fill . "currentColor")))
 525
 526 (define (setcolor r g b)
 527   (format "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
 528           (* 100 r) (* 100 g) (* 100 b)))
 529
 530 ;; rotate around given point
 531 (define (setrotation ang x y)
 532   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
 533              (- ang) x (- y)))
 534
 535 (define (text font string)
 536   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 537
 538 (define (url-link url x y)
 539   (string-append
 540    (eo 'a `(xlink:href . ,url))
 541    (eoc 'rect
 542         `(x . ,(car x))
 543         `(y . ,(car y))
 544         `(width . ,(- (cdr x) (car x)))
 545         `(height . ,(- (cdr y) (car y)))
 546         '(fill . "none")
 547         '(stroke . "none")
 548         '(stroke-width . "0.0"))
 549    (ec 'a)))
 550
 551 (define (utf-8-string pango-font-description string)
 552   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))