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