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