1
;;;; sodipodi.scm -- implement Scheme output routines for PostScript
3
;;;; source file of the GNU LilyPond music typesetter
5
;;;; (c) 2002--2004 Jan Nieuwenhuizen <janneke@gnu.org>
9
;;;; * Get mftrace 1.0.12 or newer to create the .pfa fonts:
14
;;;; * Get sodipodi-0.28 or newer
16
;;;; * Link/copy mf/out/private-fonts to ~/.sodipodi/private-fonts
18
;;;; http://www.w3.org/TR/SVG11/paths.html
21
(debug-enable 'backtrace)
23
(define-module (scm output-sodipodi))
24
(define this-module (current-module))
30
;;; Lily output interface --- cleanup and docme
32
;;; Bare minimum interface for \score { \notes c } }
35
;;; xx-output-expression
40
;;; and should intercept:
54
;;(define-public (sodipodi-output-expression expr port)
55
;; (display (eval expr this-module) port))
57
(define-public (sodipodi-output-expression expr port)
58
(display (dispatch expr) port))
60
(define (dispatch expr)
61
(let ((keyword (car expr)))
63
((eq? keyword 'some-func) "")
64
;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
65
;;((eq? keyword 'fontify) (dispatch (caddr expr)))
67
(if (module-defined? this-module keyword)
68
(apply (eval keyword this-module) (cdr expr))
71
(string-append "undefined: " (symbol->string keyword) "\n"))
77
(define output-scale 1)
80
(define urg-line-thickness 0)
81
(define line-thickness 0.001)
82
(define half-lt (/ line-thickness 2))
87
((equal? (ly:unit) "mm") (/ 72.0 25.4))
88
((equal? (ly:unit) "pt") (/ 72.0 72.27))
89
(else (error "unknown unit" (ly:unit)))))
91
;; alist containing fontname -> fontcommand assoc (both strings)
92
;;(define font-name-alist '())
97
(define (tagify tag string . attribute-alist)
100
(apply string-append (map (lambda (x) (string-append
102
(symbol->string (car x))
108
string "\n</" tag ">\n"))
111
(define (ascii->string i) (make-string 1 (integer->char i)))
112
(define (ascii->upm-string i)
115
(u2 (+ #x80 (quotient i+1 #x40)))
116
(u3 (+ #x80 (modulo i+1 #x40))))
121
(define (control->list c)
122
(list (car c) (cdr c)))
124
(define (control->string c)
126
(number->string (car c)) ","
128
(number->string (* -1 (cdr c))) " "))
130
(define (control-flip-y c)
131
(cons (car c) (* -1 (cdr c))))
133
(define (ly:numbers->string l)
135
(number->string (car l))
138
(string-append "," (ly:numbers->string (cdr l))))))
140
(define (svg-bezier l close)
141
(let* ((c0 (car (list-tail l 3)))
142
(c123 (list-head l 3)))
144
(if (not close) "M " "L ")
146
"C " (apply string-append (map control->string c123))
147
(if (not close) "" (string-append
148
"L " (control->string close))))));; " Z")))))
151
"<?xml version='1.0' standalone='no'?>
152
<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
153
'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'
156
xmlns:xlink CDATA #FIXED 'http://www.w3.org/1999/xlink'>
165
sodipodi:version='0.26'
166
xmlns='http://www.w3.org/2000/svg'
167
xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
168
xmlns:xlink='http://www.w3.org/1999/xlink'
171
sodipodi:docbase='/tmp/'
172
sodipodi:docname='/tmp/x'>
177
<g transform='translate(10,10) scale (1.0)'>
182
;; Interface functions
187
;; transform=scale and stroke don't play nice together...
188
(define (XXXbeam width slope thick)
191
(z (sqrt (+ (sqr x) (sqr y)))))
193
;; '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:0.1;stroke-linejoin:miter;stroke-linecap:butt;")
194
;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:0.000001;stroke-linejoin:miter;stroke-linecap:butt;")
195
`(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:miter;stroke-linecap:butt;" line-thickness))
196
;;`(x . ,(number->string half-lt))
198
;;`(y . ,(number->string (- half-lt (/ thick 2))))
199
`(y . ,(number->string (- 0 (/ thick 2))))
200
`(width . ,(number->string width))
201
`(height . ,(number->string thick))
202
`(ry . ,(number->string half-lt))
203
`(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
206
output-scale output-scale)))))
208
(define (beam width slope thick)
211
(z (sqrt (+ (sqr x) (sqr y)))))
213
`(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:miter;stroke-linecap:butt;" line-thickness))
215
`(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
216
`(width . ,(number->string (* output-scale width)))
217
`(height . ,(number->string (* output-scale thick)))
218
`(ry . ,(number->string (* output-scale half-lt)))
219
`(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
225
(define (bezier-sandwich l thick)
226
(let* (;;(l (eval urg-l this-module))
227
(first (list-tail l 4))
228
(first-c0 (car (list-tail first 3)))
229
(second (list-head l 4)))
231
`(stroke . "#000000")
232
`(stroke-width . ,(number->string line-thickness))
233
`(transform . ,(format #f "scale (~f,~f)"
234
output-scale output-scale))
235
`(d . ,(string-append (svg-bezier first #f)
236
(svg-bezier second first-c0))))))
240
;;(tagify "tspan" (format #f "à~2,'0x;" i))
241
(tagify "tspan" (ascii->upm-string i))
243
(format #t "can't display char: ~x\n" i)
248
(string-append "<!-- " s " -->\n"))
250
(define (define-fonts internal-external-name-mag-pairs)
251
(comment (format #f "Fonts used: ~S" internal-external-name-mag-pairs)))
257
;(define (horizontal-line x1 x2 th)
258
; (draw-line th x1 0 x2 0))
260
(define (filledbox breapth width depth height)
261
(round-filled-box breapth width depth height line-thickness))
264
"fill:black;stroke:none;text-anchor:start;writing-mode:lr;font-weight:normal;")
269
("cmr8" . ,(string-append
271
"font-family:cmr;font-style:normal;font-size:8;"))
272
("feta13" . ,(string-append
274
"font-family:LilyPond-Feta;font-style:-Feta;font-size:13;"))
275
("feta-nummer10" . ,(string-append
277
"font-family:LilyPond-feta-nummer;font-style:-feta-nummer;font-size:10;"))
278
("feta20" . ,(string-append
280
"font-family:LilyPond-feta;font-style:-feta;font-size:20;"))
281
("parmesan20" . ,(string-append
283
"font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;"))))
285
(define (get-font name-mag-pair)
286
;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
287
(let ((f (assoc (caadr name-mag-pair) font-alist)))
291
(format #t "font not found: ~s\n" (caadr name-mag-pair))
292
(cdr (assoc "feta20" font-alist))))))
294
(define (fontify name-mag-pair expr)
296
(tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
299
(comment "header-end"))
301
(define (header creator generate)
309
(define (lily-def key val)
311
((equal? key "lilypondpaperoutputscale")
313
;; If we just use transform scale (output-scale),
314
;; all fonts come out scaled too (ie, much too big)
315
;; So, we manually scale all other stuff.
316
(set! output-scale (* scale-to-unit (string->number val))))
317
((equal? key "lilypondpaperlinethickness")
318
(set! urg-line-thickness (* scale-to-unit (string->number val)))))
325
(define (placebox x y expr)
326
(tagify "g" (dispatch expr)
331
(number->string (* output-scale x))
333
(number->string (- 0 (* output-scale y)))
336
(define (round-filled-box breapth width depth height blot-diameter)
338
;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
339
`(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:miter;stroke-linecap:butt;" line-thickness))
340
`(x . ,(number->string (* output-scale (- 0 breapth))))
341
`(y . ,(number->string (* output-scale (- 0 height))))
342
`(width . ,(number->string (* output-scale (+ breapth width))))
343
`(height . ,(number->string (* output-scale (+ depth height))))
344
;;`(ry . ,(number->string (* output-scale half-lt)))
345
`(ry . ,(number->string (/ blot-diameter 2)))))
349
;; TODO: use height, set scaling?
350
(define (start-system width height)
352
;;"<g transform='translate(50,-250)'>
353
(set! system-y (+ system-y height))
354
;;(format #f "<g transform='translate(0,~1,'~f)'>" y)))
357
(comment "start-system")
358
(format #f "<g transform='translate(0.0,~f)'>\n" (* output-scale y)))))
360
(define (stop-system)
363
(comment "stop-system")
366
(define stop-last-system stop-system)
369
;; to unicode or not?
373
(apply string-appendb
374
(map (lambda (x) (ascii->upm-string (char->integer x)))
375
(string->list s))))))
added
removed
scm/output-sodipodi.scm
