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