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   (ly:format "~4f ~4f" (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" (string-join (map offset->point c123) " ")
 100       (if (not close) "" "z"))))
 101
 102 (define (sqr x)
 103   (* x x))
 104
 105 (define (integer->entity integer)
 106   (fancy-format "&#x~x;" integer))
 107
 108 (define (char->entity char)
 109   (integer->entity (char->integer char)))
 110
 111 (define (string->entities string)
 112   (apply string-append
 113          (map (lambda (x) (char->entity x)) (string->list string))))
 114
 115 (define svg-element-regexp
 116   (make-regexp "^(<[a-z]+) ?(.*>)"))
 117
 118 (define scaled-element-regexp
 119   (make-regexp "^(<[a-z]+ transform=\")(scale.[-0-9. ]+,[-0-9. ]+.\" .*>)"))
 120
 121 (define pango-description-regexp-comma
 122   (make-regexp ",( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 123
 124 (define pango-description-regexp-nocomma
 125   (make-regexp "( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 126
 127 (define (pango-description-to-text str expr)
 128   (define alist '())
 129   (define (set-attribute attr val)
 130     (set! alist (assoc-set! alist attr val)))
 131   (let*
 132     ((match-1 (regexp-exec pango-description-regexp-comma str))
 133      (match-2 (regexp-exec pango-description-regexp-nocomma str))
 134      (match (if match-1
 135                 match-1
 136                 match-2)))
 137
 138     (if (regexp-match? match)
 139         (begin
 140           (set-attribute 'font-family (match:prefix match))
 141           (if (string? (match:substring match 1))
 142               (set-attribute 'font-weight "bold"))
 143           (if (string? (match:substring match 2))
 144               (set-attribute 'font-style "italic"))
 145           (if (string? (match:substring match 3))
 146               (set-attribute 'font-variant "small-caps"))
 147           (set-attribute 'font-size
 148                          (/ (string->number (match:substring match 4))
 149                             lily-unit-length))
 150           (set-attribute 'text-anchor "start")
 151           (set-attribute 'fill "currentColor"))
 152         (ly:warning (_ "cannot decypher Pango description: ~a") str))
 153
 154     (apply entity 'text expr (reverse! alist))))
 155
 156 (define (dump-path path scale . rest)
 157   (define alist '())
 158   (define (set-attribute attr val)
 159     (set! alist (assoc-set! alist attr val)))
 160   (if (not (null? rest))
 161       (let* ((dx (car rest))
 162              (dy (cadr rest))
 163              (total-x (+ dx next-horiz-adv)))
 164         (if (or (not (zero? total-x))
 165                 (not (zero? dy)))
 166             (let ((x (ly:format "~4f" total-x))
 167                   (y (ly:format "~4f" dy)))
 168               (set-attribute 'transform
 169                              (string-append
 170                                "translate(" x ", " y ") "
 171                                "scale(" scale ", -" scale ")")))
 172             (set-attribute 'transform
 173                            (string-append
 174                              "scale(" scale ", -" scale ")"))))
 175       (set-attribute 'transform (string-append
 176                                   "scale(" scale ", -" scale ")")))
 177
 178   (set-attribute 'd path)
 179   (set-attribute 'fill "currentColor")
 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          (second (list-head lst 4)))
 309     (entity 'path ""
 310             '(stroke-linejoin . "round")
 311             '(stroke-linecap . "round")
 312             '(stroke . "currentColor")
 313             '(fill . "currentColor")
 314             `(stroke-width . ,thick)
 315             `(d . ,(string-append (svg-bezier first #f)
 316                                   (svg-bezier second #t)))
 317             )))
 318
 319 (define (char font i)
 320   (dispatch
 321    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 322
 323 (define (circle radius thick is-filled)
 324   (entity
 325    'circle ""
 326    '(stroke-linejoin . "round")
 327    '(stroke-linecap . "round")
 328    `(fill . ,(if is-filled "currentColor" "none"))
 329    `(stroke . "currentColor")
 330    `(stroke-width . ,thick)
 331    `(r . ,radius)))
 332
 333 (define (dashed-line thick on off dx dy phase)
 334   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
 335
 336 (define (draw-line thick x1 y1 x2 y2 . alist)
 337   (apply entity 'line ""
 338          (append
 339           `((stroke-linejoin . "round")
 340             (stroke-linecap . "round")
 341             (stroke-width . ,thick)
 342             (stroke . "currentColor")
 343             (x1 . ,x1)
 344             (y1 . ,(- y1))
 345             (x2 . ,x2)
 346             (y2 . ,(- y2)))
 347           alist)))
 348
 349 (define (ellipse x-radius y-radius thick is-filled)
 350   (entity
 351    'ellipse ""
 352    '(stroke-linejoin . "round")
 353    '(stroke-linecap . "round")
 354    `(fill . ,(if is-filled "currentColor" "none"))
 355    `(stroke . "currentColor")
 356    `(stroke-width . ,thick)
 357    `(rx . ,x-radius)
 358    `(ry . ,y-radius)))
 359
 360 (define (embedded-svg string)
 361   string)
 362
 363 (define (glyph-string font size cid glyphs)
 364   (define path "")
 365   (if (= 1 (length glyphs))
 366       (set! path (feta-alphabet-to-path font size (car glyphs)))
 367       (begin
 368         (set! path
 369               (string-append (eo 'g)
 370                              (string-join
 371                                (map (lambda (x)
 372                                       (feta-alphabet-to-path font size x))
 373                                     glyphs)
 374                                "\n")
 375                              (ec 'g)))))
 376   (set! next-horiz-adv 0.0)
 377   path)
 378
 379 (define (grob-cause offset grob)
 380   "")
 381
 382 (define (named-glyph font name)
 383   (dispatch `(fontify ,font ,name)))
 384
 385 (define (no-origin)
 386   "")
 387
 388 (define (oval x-radius y-radius thick is-filled)
 389   (let ((x-max x-radius)
 390         (x-min (- x-radius))
 391         (y-max y-radius)
 392         (y-min (- y-radius)))
 393     (entity
 394      'path ""
 395      '(stroke-linejoin . "round")
 396      '(stroke-linecap . "round")
 397      `(fill . ,(if is-filled "currentColor" "none"))
 398      `(stroke . "currentColor")
 399      `(stroke-width . ,thick)
 400      `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz"
 401                x-max 0
 402                x-max y-max
 403                x-min y-max
 404                x-min 0
 405                x-max y-min
 406                x-max 0)))))
 407
 408 (define (path thick commands)
 409   (define (convert-path-exps exps)
 410     (if (pair? exps)
 411         (let*
 412           ((head (car exps))
 413            (rest (cdr exps))
 414            (arity
 415              (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
 416                    ((memq head '(rcurveto curveto)) 6)
 417                    (else 1)))
 418            (args (take rest arity))
 419            (svg-head (assoc-get head
 420                                 '((rmoveto . m)
 421                                   (rcurveto . c)
 422                                   (curveto . C)
 423                                   (moveto . M)
 424                                   (lineto . L)
 425                                   (rlineto . l))
 426                                 "")))
 427
 428           (cons (format "~a~a"
 429                         svg-head (number-list->point args))
 430                 (convert-path-exps (drop rest arity))))
 431         '()))
 432
 433   (entity 'path ""
 434           `(stroke-width . ,thick)
 435           '(stroke-linejoin . "round")
 436           '(stroke-linecap . "round")
 437           '(stroke . "currentColor")
 438           '(fill . "none")
 439           `(d . ,(apply string-append (convert-path-exps commands)))))
 440
 441 (define (placebox x y expr)
 442   (if (string-null? expr)
 443       ""
 444       (let*
 445         ((normal-element (regexp-exec svg-element-regexp expr))
 446          (scaled-element (regexp-exec scaled-element-regexp expr))
 447          (scaled? (if scaled-element #t #f))
 448          (match (if scaled? scaled-element normal-element))
 449          (string1 (match:substring match 1))
 450          (string2 (match:substring match 2)))
 451
 452         (if scaled?
 453             (string-append string1
 454                            (ly:format "translate(~4f, ~4f) " x (- y))
 455                            string2
 456                            "\n")
 457             (string-append string1
 458                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 459                                       x (- y))
 460                            string2
 461                            "\n")))))
 462
 463 (define (polygon coords blot-diameter is-filled)
 464   (entity
 465    'polygon ""
 466    '(stroke-linejoin . "round")
 467    '(stroke-linecap . "round")
 468    `(stroke-width . ,blot-diameter)
 469    `(fill . ,(if is-filled "currentColor" "none"))
 470    '(stroke . "currentColor")
 471    `(points . ,(string-join
 472                 (map offset->point (ly:list->offsets '() coords))))
 473    ))
 474
 475 (define (resetcolor)
 476   "</g>\n")
 477
 478 (define (resetrotation ang x y)
 479   "</g>\n")
 480
 481 (define (round-filled-box breapth width depth height blot-diameter)
 482   (entity 'rect ""
 483           ;; The stroke will stick out.  To use stroke,
 484           ;; the stroke-width must be subtracted from all other dimensions.
 485           ;;'(stroke-linejoin . "round")
 486           ;;'(stroke-linecap . "round")
 487           ;;`(stroke-width . ,blot)
 488           ;;'(stroke . "red")
 489           ;;'(fill . "orange")
 490
 491           `(x . ,(- breapth))
 492           `(y . ,(- height))
 493           `(width . ,(+ breapth width))
 494           `(height . ,(+ depth height))
 495           `(ry . ,(/ blot-diameter 2))
 496           '(fill . "currentColor")
 497           ))
 498
 499 (define (setcolor r g b)
 500   (format "<g color=\"rgb(~a%,~a%,~a%)\">\n"
 501           (* 100 r) (* 100 g) (* 100 b)
 502           ))
 503
 504 ;; rotate around given point
 505 (define (setrotation ang x y)
 506   (format "<g transform=\"rotate(~a,~a,~a)\">\n"
 507     (number->string (* -1 ang))
 508     (number->string x)
 509     (number->string (* -1 y))))
 510
 511 (define (text font string)
 512   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 513
 514 (define (url-link url x y)
 515   (string-append
 516    (eo 'a `(xlink:href . ,url))
 517    (eoc 'rect
 518         `(x . ,(car x))
 519         `(y . ,(car y))
 520         `(width . ,(- (cdr x) (car x)))
 521         `(height . ,(- (cdr y) (car y)))
 522         '(fill . "none")
 523         '(stroke . "none")
 524         '(stroke-width . "0.0"))
 525    (ec 'a)))
 526
 527 (define (utf-8-string pango-font-description string)
 528   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))