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