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