]> git.donarmstrong.com Git - lilypond.git/blob - scm/output-svg.scm
(allfiles): look for .ly rather
[lilypond.git] / 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--2006 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  (lily)
27  (srfi srfi-1)
28  (srfi srfi-13))
29
30
31 (define lily-unit-length 1.75)
32
33 (define (dispatch expr)
34   (let ((keyword (car expr)))
35     (cond
36      ((eq? keyword 'some-func) "")
37      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
38      (else
39       (if (module-defined? this-module keyword)
40           (apply (eval keyword this-module) (cdr expr))
41           (begin
42             (ly:warning (_ "undefined: ~S") keyword)
43             ""))))))
44
45 ;; Helper functions
46 (define-public (attributes attributes-alist)
47   (apply string-append
48          (map (lambda (x) (format #f " ~s=\"~a\"" (car x) (cdr x)))
49               attributes-alist)))
50
51 (define-public (eo entity . attributes-alist)
52   "o = open"
53   (format #f "<~S~a>\n" entity (attributes attributes-alist)))
54
55 (define-public (eoc entity . attributes-alist)
56   " oc = open/close"
57   (format #f "<~S~a/>\n" entity (attributes attributes-alist)))
58
59 (define-public (ec entity)
60   "c = close"
61   (format #f "</~S>\n" entity))
62
63
64
65 (define-public (entity entity string . attributes-alist)
66   (if (equal? string "")
67       (apply eoc entity attributes-alist)
68       (string-append
69        (apply eo (cons entity attributes-alist)) string (ec entity))))
70
71 (define (offset->point o)
72   (format #f " ~S,~S" (car o)  (- (cdr o))))
73
74 (define (number-list->point lst)
75   (define (helper lst)
76     (if (null? lst)
77         '()
78         (cons (format "~S,~S" (car lst) (cadr lst))
79               (helper (cddr lst)))))
80
81   (string-join (helper lst) " "))  
82
83
84 (define (svg-bezier lst close)
85   (let* ((c0 (car (list-tail lst 3)))
86          (c123 (list-head lst 3)))
87     (string-append
88      (if (not close) "M " "L ")
89      (offset->point c0)
90      "C " (apply string-append (map offset->point c123))
91      (if (not close) "" (string-append
92                          "L " (offset->point close))))))
93
94 (define (sqr x)
95   (* x x))
96
97 (define (integer->entity integer)
98   (format #f "&#x~x;" integer))
99
100 (define (char->entity char)
101   (integer->entity (char->integer char)))
102
103 (define (string->entities string)
104   (apply string-append
105          (map (lambda (x) (char->entity x)) (string->list string))))
106
107 (define pango-description-regexp-comma
108   (make-regexp "^([^,]+), ?([-a-zA-Z_]*) ([0-9.]+)$"))
109
110 (define pango-description-regexp-nocomma
111   (make-regexp "^([^ ]+) ([-a-zA-Z_]*) ?([0-9.]+)$"))
112
113 (define (pango-description-to-svg-font str)
114   (let*
115       ((size 4.0)
116        (family "Helvetica")
117        (style #f)
118        (match-1 (regexp-exec pango-description-regexp-comma str))
119        (match-2 (regexp-exec pango-description-regexp-nocomma str))
120        (match (if match-1
121                   match-1
122                   match-2)))
123
124     (if (regexp-match? match)
125         (begin
126           (set! family (match:substring match 1))
127           (if (< 0 (string-length (match:substring match 2)))
128               (set! style (match:substring match 2)))
129           (set! size
130                 (string->number (match:substring match 3))))
131
132         (ly:warning (_ "can't decypher Pango description: ~a") str))
133
134     (set! style
135           (if (string? style)
136               (format "font-style:~a;" style)
137               ""))
138     
139     (format "font-family:~a;~afont-size:~a;text-anchor:west"
140             family
141             style
142             (/ size lily-unit-length))
143     ))
144
145 ;;; FONT may be font smob, or pango font string
146 (define (svg-font font)
147   (if (string? font)
148       (pango-description-to-svg-font font)
149       (let ((name-style (font-name-style font))
150             (size (modified-font-metric-font-scaling font))
151             (anchor "west"))
152
153         (format #f "font-family:~a;font-style:~a;font-size:~a;text-anchor:~a;"
154                 (car name-style) (cadr name-style)
155                 size anchor))))
156
157 (define (fontify font expr)
158   (entity 'text expr
159           `(style . ,(svg-font font))
160           '(fill . "currentColor")
161           ))
162
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164 ;;; stencil outputters
165 ;;;
166
167 ;;; catch-all for missing stuff
168 ;;; comment this out to see find out what functions you miss :-)
169
170 (if #f
171     (begin
172       (define (dummy . foo) "")
173       (map (lambda (x) (module-define! this-module x dummy))
174            (append
175             (ly:all-stencil-expressions)
176             (ly:all-output-backend-commands)))
177       ))
178
179 (define (url-link url x y)
180   (string-append
181    (eo 'a `(xlink:href . ,url))
182    (eoc 'rect
183         `(x . ,(car x))
184         `(y . ,(car y))
185         `(width . ,(- (cdr x) (car x)))
186         `(height . ,(- (cdr y) (car y)))
187         '(fill . "none")
188         '(stroke . "none")
189         '(stroke-width . "0.0"))
190    (ec 'a)))
191
192 (define (grob-cause offset grob)
193   "")
194
195 (define (no-origin)
196   "")
197
198
199
200 (define (bezier-sandwich lst thick)
201   (let* ((first (list-tail lst 4))
202          (first-c0 (car (list-tail first 3)))
203          (second (list-head lst 4)))
204     (entity 'path ""
205             '(stroke-linejoin . "round")
206             '(stroke-linecap . "round")
207             '(stroke . "currentColor")
208             '(fill . "currentColor")
209             `(stroke-width . ,thick)
210             `(d . ,(string-append (svg-bezier first #f)
211                                   (svg-bezier second first-c0)))
212             )))
213
214 (define (path thick commands)
215   (define (convert-path-exps exps)
216     (if (pair? exps)
217         (let*
218             ((head (car exps))
219              (rest (cdr exps))
220              (arity 
221               (cond
222                ((memq head '(rmoveto rlineto lineto moveto)) 2)
223                ((memq head '(rcurveto curveto)) 6)
224                (else 1)))
225              (args (take rest arity))
226              (svg-head (assoc-get head '((rmoveto . m)
227                                          (rcurveto . c)
228                                          (curveto . C)
229                                          (moveto . M)
230                                          (lineto . L)
231                                          (rlineto . l))
232                                   ""))
233              )
234
235           (cons (format "~a~a "
236                         svg-head (number-list->point args)
237                         )
238                 (convert-path-exps (drop rest arity))))
239         '()))
240   
241   (entity 'path ""
242           `(stroke-width . ,thick)
243           '(stroke-linejoin . "round")
244           '(stroke-linecap . "round")
245           '(stroke . "currentColor")
246           '(fill . "none")
247           `(d . ,(string-join (convert-path-exps commands) " "))))
248   
249 (define (char font i)
250   (dispatch
251    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
252
253 (define-public (comment s)
254   (string-append "<!-- " s " !-->\n"))
255
256 (define (draw-line thick x1 y1 x2 y2 . alist)
257   
258   (apply entity 'line ""
259          (append
260           `((stroke-linejoin . "round")
261             (stroke-linecap . "round")
262             (stroke-width . ,thick)
263             (stroke . "currentColor")
264             (x1 . ,x1)
265             (y1 . ,(- y1))
266             (x2 . ,x2)
267             (y2 . ,(- y2)))
268           alist)))
269
270 (define (dashed-line thick on off dx dy phase)
271   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
272
273 (define (named-glyph font name)
274   (dispatch
275    `(fontify ,font ,(entity 'tspan
276                             (integer->entity
277                              (ly:font-glyph-name-to-charcode font name))))))
278
279 (define (placebox x y expr)
280   (entity 'g
281           expr
282           ;; FIXME: Not using GNU coding standards [translate ()] here
283           ;; to work around a bug in Microsoft Internet Explorer 6.0
284           `(transform . ,(format #f "translate(~f, ~f)"
285                                  x (- y)))))
286
287 (define (polygon coords blot-diameter is-filled)
288   (entity
289    'polygon ""
290    '(stroke-linejoin . "round")
291    '(stroke-linecap . "round")
292    `(stroke-width . ,blot-diameter)
293    `(fill . ,(if is-filled "currentColor" "none"))
294    '(stroke . "currentColor")
295    `(points . ,(string-join
296                 (map offset->point (ly:list->offsets '() coords))))
297    ))
298
299 ;; rotate around given point
300 (define (setrotation ang x y)
301   (format "<g transform=\"rotate(~a,~a,~a)\">"
302     (number->string (* -1 ang))
303     (number->string x)
304     (number->string (* -1 y))))
305
306 (define (resetrotation ang x y)
307   "</g>")
308
309 (define (round-filled-box breapth width depth height blot-diameter)
310   (entity 'rect ""
311           ;; The stroke will stick out.  To use stroke,
312           ;; the stroke-width must be subtracted from all other dimensions.
313           ;;'(stroke-linejoin . "round")
314           ;;'(stroke-linecap . "round")
315           ;;`(stroke-width . ,blot)
316           ;;'(stroke . "red")
317           ;;'(fill . "orange")
318
319           `(x . ,(- breapth))
320           `(y . ,(- height))
321           `(width . ,(+ breapth width))
322           `(height . ,(+ depth height))
323           `(ry . ,(/ blot-diameter 2))
324           ))
325
326 (define (circle radius thick is-filled)
327   (entity
328    'circle ""
329    '(stroke-linejoin . "round")
330    '(stroke-linecap . "round")
331    `(fill . ,(if is-filled "currentColor" "none"))
332    `(stroke . "currentColor")
333    `(stroke-width . ,thick)
334    `(r . ,radius)))
335
336 (define (text font string)
337   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
338
339 (define (utf-8-string pango-font-description string)
340   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))
341
342
343
344 (define (setcolor r g b)
345   (format "<g color=\"rgb(~a%,~a%,~a%)\">"
346           (* 100 r) (* 100 g) (* 100 b)
347           ))
348
349 (define (resetcolor)
350   "</g>")