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