scm/output-svg.scm

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