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 (zero? total-x))
 166                 (not (zero? 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   (set-attribute 'fill "currentColor")
 181   (apply entity 'path "" (reverse alist)))
 182
 183
 184 ;; A global variable for keeping track of the *cumulative*
 185 ;; horizontal advance for glyph strings, but only if there
 186 ;; is more than one glyph.
 187 (define next-horiz-adv 0.0)
 188
 189 ;; Matches the required "unicode" attribute from <glyph>
 190 (define glyph-unicode-value-regexp
 191   (make-regexp "unicode=\"([^\"]+)\""))
 192
 193 ;; Matches the optional path data from <glyph>
 194 (define glyph-path-regexp
 195   (make-regexp "d=\"([-MmZzLlHhVvCcSsQqTt0-9.\n ]*)\""))
 196
 197 ;; Matches a complete <glyph> element with the glyph-name
 198 ;; attribute value of NAME.  For example:
 199 ;;
 200 ;; <glyph glyph-name="period" unicode="." horiz-adv-x="110"
 201 ;; d="M0 55c0 30 25 55 55 55s55 -25 55
 202 ;; -55s-25 -55 -55 -55s-55 25 -55 55z" />
 203 ;;
 204 ;; TODO: it would be better to use an XML library to extract
 205 ;; the glyphs instead, and store them in a hash table.  --pmccarty
 206 ;;
 207 (define (glyph-element-regexp name)
 208   (make-regexp (string-append "<glyph"
 209                               "(([\r\n\t ]+[-a-z]+=\"[^\"]*\")+)?"
 210                               "[\r\n\t ]+glyph-name=\"("
 211                               name
 212                               ")\""
 213                               "(([\r\n\t ]+[-a-z]+=\"[^\"]*\")+)?"
 214                               "([\r\n\t ]+)?"
 215                               "/>")))
 216
 217 (define (extract-glyph all-glyphs name size . rest)
 218   (let* ((new-name (regexp-quote name))
 219          (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
 220          (glyph (match:substring regexp))
 221          (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
 222          (unicode-attr-value (match:substring unicode-attr 1))
 223          (unicode-attr? (regexp-match? unicode-attr))
 224          (d-attr (regexp-exec glyph-path-regexp glyph))
 225          (d-attr-value "")
 226          (d-attr? (regexp-match? d-attr))
 227          ;; TODO: not urgent, but do not hardcode this value
 228          (units-per-em 1000)
 229          (font-scale (ly:format "~4f" (/ size units-per-em)))
 230          (path ""))
 231
 232     (if (and unicode-attr? (not unicode-attr-value))
 233         (ly:warning (_ "Glyph must have a unicode value")))
 234
 235     (if d-attr? (set! d-attr-value (match:substring d-attr 1)))
 236
 237     (cond (
 238            ;; Glyph-strings with path data
 239            (and d-attr? (not (null? rest)))
 240            (begin
 241              (set! path (apply dump-path d-attr-value
 242                                          font-scale
 243                                          (list (cadr rest) (caddr rest))))
 244              (set! next-horiz-adv (+ next-horiz-adv
 245                                      (car rest)))
 246              path))
 247           ;; Glyph-strings without path data ("space")
 248           ((and (not d-attr?) (not (null? rest)))
 249            (begin
 250              (set! next-horiz-adv (+ next-horiz-adv
 251                                      (car rest)))
 252              ""))
 253           ;; Font smobs with path data
 254           ((and d-attr? (null? rest))
 255             (set! path (dump-path d-attr-value font-scale))
 256             path)
 257           ;; Font smobs without path data ("space")
 258           (else
 259             ""))))
 260
 261 (define (extract-glyph-info all-glyphs glyph size)
 262   (let* ((offsets (list-head glyph 3))
 263          (glyph-name (car (reverse glyph))))
 264     (apply extract-glyph all-glyphs glyph-name size offsets)))
 265
 266 (define (svg-defs svg-font)
 267   (let ((start (string-contains svg-font "<defs>"))
 268         (end (string-contains svg-font "</defs>")))
 269     (substring svg-font (+ start 7) (- end 1))))
 270
 271 (define (cache-font svg-font size glyph)
 272   (let ((all-glyphs (svg-defs (cached-file-contents svg-font))))
 273     (if (list? glyph)
 274         (extract-glyph-info all-glyphs glyph size)
 275         (extract-glyph all-glyphs glyph size))))
 276
 277
 278 (define (feta-alphabet-to-path font size glyph)
 279   (let* ((name-style (font-name-style font))
 280          (scaled-size (/ size lily-unit-length))
 281          (font-file (ly:find-file (string-append name-style ".svg"))))
 282
 283     (if font-file
 284         (cache-font font-file scaled-size glyph)
 285         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 286
 287
 288 (define (font-smob-to-path font glyph)
 289   (let* ((name-style (font-name-style font))
 290          (scaled-size (modified-font-metric-font-scaling font))
 291          (font-file (ly:find-file (string-append name-style ".svg"))))
 292
 293     (if font-file
 294         (cache-font font-file scaled-size glyph)
 295         (ly:warning (_ "cannot find SVG font ~S") font-file))))
 296
 297
 298 (define (fontify font expr)
 299   (if (string? font)
 300       (pango-description-to-text font expr)
 301       (font-smob-to-path font expr)))
 302
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304 ;;; stencil outputters
 305 ;;;
 306
 307 (define (bezier-sandwich lst thick)
 308   (let* ((first (list-tail lst 4))
 309          (first-c0 (car (list-tail first 3)))
 310          (second (list-head lst 4)))
 311     (entity 'path ""
 312             '(stroke-linejoin . "round")
 313             '(stroke-linecap . "round")
 314             '(stroke . "currentColor")
 315             '(fill . "currentColor")
 316             `(stroke-width . ,thick)
 317             `(d . ,(string-append (svg-bezier first #f)
 318                                   (svg-bezier second first-c0)))
 319             )))
 320
 321 (define (char font i)
 322   (dispatch
 323    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 324
 325 (define (circle radius thick is-filled)
 326   (entity
 327    'circle ""
 328    '(stroke-linejoin . "round")
 329    '(stroke-linecap . "round")
 330    `(fill . ,(if is-filled "currentColor" "none"))
 331    `(stroke . "currentColor")
 332    `(stroke-width . ,thick)
 333    `(r . ,radius)))
 334
 335 (define (dashed-line thick on off dx dy phase)
 336   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
 337
 338 (define (draw-line thick x1 y1 x2 y2 . alist)
 339   (apply entity 'line ""
 340          (append
 341           `((stroke-linejoin . "round")
 342             (stroke-linecap . "round")
 343             (stroke-width . ,thick)
 344             (stroke . "currentColor")
 345             (x1 . ,x1)
 346             (y1 . ,(- y1))
 347             (x2 . ,x2)
 348             (y2 . ,(- y2)))
 349           alist)))
 350
 351 (define (ellipse x-radius y-radius thick is-filled)
 352   (entity
 353    'ellipse ""
 354    '(stroke-linejoin . "round")
 355    '(stroke-linecap . "round")
 356    `(fill . ,(if is-filled "currentColor" "none"))
 357    `(stroke . "currentColor")
 358    `(stroke-width . ,thick)
 359    `(rx . ,x-radius)
 360    `(ry . ,y-radius)))
 361
 362 (define (embedded-svg string)
 363   string)
 364
 365 (define (glyph-string font size cid glyphs)
 366   (define path "")
 367   (if (= 1 (length glyphs))
 368       (set! path (feta-alphabet-to-path font size (car glyphs)))
 369       (begin
 370         (set! path
 371               (string-append (eo 'g)
 372                              (string-join
 373                                (map (lambda (x)
 374                                       (feta-alphabet-to-path font size x))
 375                                     glyphs)
 376                                "\n")
 377                              (ec 'g)))))
 378   (set! next-horiz-adv 0.0)
 379   path)
 380
 381 (define (grob-cause offset grob)
 382   "")
 383
 384 (define (named-glyph font name)
 385   (dispatch `(fontify ,font ,name)))
 386
 387 (define (no-origin)
 388   "")
 389
 390 (define (oval x-radius y-radius thick is-filled)
 391   (let ((x-max x-radius)
 392         (x-min (- x-radius))
 393         (y-max y-radius)
 394         (y-min (- y-radius)))
 395     (entity
 396      'path ""
 397      '(stroke-linejoin . "round")
 398      '(stroke-linecap . "round")
 399      `(fill . ,(if is-filled "currentColor" "none"))
 400      `(stroke . "currentColor")
 401      `(stroke-width . ,thick)
 402      `(d . ,(ly:format "M~4f,~4f C~4f,~4f  ~4f,~4f ~4f,~4f S~4f,~4f ~4f,~4f"
 403                x-max 0
 404                x-max y-max
 405                x-min y-max
 406                x-min 0
 407                x-max y-min
 408                x-max 0)))))
 409
 410 (define (path thick commands)
 411   (define (convert-path-exps exps)
 412     (if (pair? exps)
 413         (let*
 414             ((head (car exps))
 415              (rest (cdr exps))
 416              (arity
 417               (cond
 418                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 419                ((memq head '(rcurveto curveto)) 6)
 420                (else 1)))
 421              (args (take rest arity))
 422              (svg-head (assoc-get head '((rmoveto . m)
 423                                          (rcurveto . c)
 424                                          (curveto . C)
 425                                          (moveto . M)
 426                                          (lineto . L)
 427                                          (rlineto . l))
 428                                   ""))
 429              )
 430
 431           (cons (format "~a~a "
 432                         svg-head (number-list->point args)
 433                         )
 434                 (convert-path-exps (drop rest arity))))
 435         '()))
 436
 437   (entity 'path ""
 438           `(stroke-width . ,thick)
 439           '(stroke-linejoin . "round")
 440           '(stroke-linecap . "round")
 441           '(stroke . "currentColor")
 442           '(fill . "none")
 443           `(d . ,(string-join (convert-path-exps commands) " "))))
 444
 445 (define (placebox x y expr)
 446   (if (string-null? expr)
 447       ""
 448       (let*
 449         ((normal-element (regexp-exec svg-element-regexp expr))
 450          (scaled-element (regexp-exec scaled-element-regexp expr))
 451          (scaled? (if scaled-element #t #f))
 452          (match (if scaled? scaled-element normal-element))
 453          (string1 (match:substring match 1))
 454          (string2 (match:substring match 2)))
 455
 456         (if scaled?
 457             (string-append string1
 458                            (ly:format "translate(~4f, ~4f) " x (- y))
 459                            string2
 460                            "\n")
 461             (string-append string1
 462                            (ly:format " transform=\"translate(~4f, ~4f)\" "
 463                                       x (- y))
 464                            string2
 465                            "\n")))))
 466
 467 (define (polygon coords blot-diameter is-filled)
 468   (entity
 469    'polygon ""
 470    '(stroke-linejoin . "round")
 471    '(stroke-linecap . "round")
 472    `(stroke-width . ,blot-diameter)
 473    `(fill . ,(if is-filled "currentColor" "none"))
 474    '(stroke . "currentColor")
 475    `(points . ,(string-join
 476                 (map offset->point (ly:list->offsets '() coords))))
 477    ))
 478
 479 (define (resetcolor)
 480   "</g>\n")
 481
 482 (define (resetrotation ang x y)
 483   "</g>\n")
 484
 485 (define (round-filled-box breapth width depth height blot-diameter)
 486   (entity 'rect ""
 487           ;; The stroke will stick out.  To use stroke,
 488           ;; the stroke-width must be subtracted from all other dimensions.
 489           ;;'(stroke-linejoin . "round")
 490           ;;'(stroke-linecap . "round")
 491           ;;`(stroke-width . ,blot)
 492           ;;'(stroke . "red")
 493           ;;'(fill . "orange")
 494
 495           `(x . ,(- breapth))
 496           `(y . ,(- height))
 497           `(width . ,(+ breapth width))
 498           `(height . ,(+ depth height))
 499           `(ry . ,(/ blot-diameter 2))
 500           '(fill . "currentColor")
 501           ))
 502
 503 (define (setcolor r g b)
 504   (format "<g color=\"rgb(~a%,~a%,~a%)\">\n"
 505           (* 100 r) (* 100 g) (* 100 b)
 506           ))
 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))))