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