scm/output-svg.scm

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