1 ;;; pdf.scm -- implement Scheme output routines for PDF.
3 ;;; source file of the GNU LilyPond music typesetter
5 ;;; (c) 2001 Stephen Peters <portnoy@portnoy.org>
7 ; currently no font commands; this is a helper for pdftex.scm.
9 (define (pdf-scm action-name)
10 ; simple commands to store and update currentpoint. This makes the
11 ; other procedures simple rewrites of the PostScript code.
12 (define currentpoint (cons 0 0))
14 (string-append (ly-number->string (car currentpoint)) " "
15 (ly-number->string (cdr currentpoint)) " "))
17 (set! currentpoint (cons x y))
18 (string-append (showcp) "m "))
19 (define (moveto-pair pair)
20 (moveto (car pair) (cdr pair)))
22 (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
24 (set! currentpoint (cons x y))
25 (string-append (showcp) "l "))
26 (define (lineto-pair pair)
27 (lineto (car pair) (cdr pair)))
29 (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
30 (define (curveto x1 y1 x2 y2 x y)
31 (set! currentpoint (cons x y))
32 (string-append (ly-number->string x1) (ly-number->string y1)
33 (ly-number->string x2) (ly-number->string y2)
34 (ly-number->string x) (ly-number->string y) "c "))
35 (define (curveto-pairs pt1 pt2 pt)
36 (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
37 (define (closefill) "h f ")
38 (define (closestroke) "S ")
39 (define (setlinewidth w) (string-append (ly-number->string w) "w "))
40 (define (setgray g) (string-append (ly-number->string g) "g "))
41 (define (setlineparams) "1 j 1 J ")
43 (define (beam width slope thick)
44 (let ((ht (* slope width)))
45 (string-append (moveto 0 (- (/ thick 2)))
48 (lineto 0 (/ thick 2))
52 (string-append "% " s "\n"))
54 (define (brack-traject pair ds alpha)
55 (let ((alpha-rad (* alpha (/ 3.141592654 180))))
56 (cons (+ (car pair) (* (cos alpha-rad) ds))
57 (+ (cdr pair) (* (sin alpha-rad) ds)))))
59 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
60 (let* ((halfht (+ (/ height 2) thick))
61 (farpt (cons (+ thick arch_height)
62 (+ (- halfht arch_thick) arch_width)))
64 (string-append (moveto 0 0)
66 (lineto thick (- halfht arch_thick))
68 (brack-traject (cons thick
69 (- halfht arch_thick))
70 (* 0.4 arch_height) 0)
79 (brack-traject (cons (/ thick 2) halfht)
84 (string-append (setlinewidth (/ thick 2))
86 "q 1 0 0 -1 0 0 cm " ; flip coords
92 (invoke-char " show" i))
94 (define (hairpin thick width starth endh )
95 (string-append (setlinewidth thick)
99 (lineto width (- endh))
102 (define (dashed-slur thick dash l)
103 (string-append (setlineparams)
104 "[ " (ly-number->string dash) " "
105 (ly-number->string (* 10 thick)) " ] 0 d "
107 (moveto-pair (car l))
108 (apply curveto (cdr l))
111 (define (dashed-line thick on off dx dy)
112 (string-append (setlineparams)
113 "[ " (ly-number->string on) " "
114 (ly-number->string off) " ] 0 d "
120 (define (repeat-slash width slope beamthick)
121 (let* ((height (/ beamthick slope))
122 (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
123 (string-append (moveto 0 0)
125 (rlineto width (* slope width))
129 (define (end-output) "")
131 (define (experimental-on) "")
133 (define (filledbox breadth width depth height)
134 (string-append (ly-number->string (- breadth))
135 (ly-number->string (- depth))
136 (ly-number->string (+ breadth width))
137 (ly-number->string (+ depth height))
140 (define (font-def i s) "")
142 (define (font-switch i) "")
144 (define (header-end) "")
146 (define (lily-def key val) "")
148 (define (header creator generate) "")
150 (define (invoke-char s i)
152 "(\\" (inexact->string i 8) ") " s " " ))
154 (define (invoke-dim1 s d)
156 (ly-number->string (* d (/ 72.27 72))) " " s ))
158 (define (placebox x y s) "")
160 (define (bezier-sandwich l thick)
161 (string-append (setlinewidth thick)
162 (moveto-pair (list-ref l 7))
163 (curveto-pairs (list-ref l 4)
166 (lineto-pair (list-ref l 3))
167 (curveto-pairs (list-ref l 0)
172 (define (start-line height) "")
174 (define (stem breadth width depth height)
175 (filledbox breadth width depth height))
177 (define (stop-line) "")
181 (define (volta h w thick vert_start vert_end)
182 (string-append (setlinewidth thick)
185 (string-append (moveto 0 0)
189 (if (= vert_end 0) (lineto w 0) "")
192 (define (tuplet ht gap dx dy thick dir)
193 (let ((gapy (* (/ dy dx) gap)))
194 (string-append (setlinewidth thick)
196 (moveto 0 (- (* ht dir)))
198 (lineto (/ (- dx gap) 2)
200 (moveto (/ (+ dx gap) 2)
203 (lineto dx (- dy (* ht dir)))
206 (define (unknown) "\n unknown\n")
208 ; Problem here -- we're using /F18 for the font, but we don't know
209 ; for sure that that will exist.
210 (define (ez-ball ch letter-col ball-col)
211 (let ((origin (cons 0.45 0)))
212 (string-append (setgray 0)
214 (moveto-pair origin) (lineto-pair origin)
218 (moveto-pair origin) (lineto-pair origin)
224 "-0.28 -0.30 Td " ; move for text block
225 "[(" ch ")] TJ ET ")))
227 (define (define-origin a b c ) "")
228 (define (no-origin) "")
231 (cond ((eq? action-name 'all-definitions)
234 (define tuplet ,tuplet)
235 (define bracket ,bracket)
237 (define volta ,volta)
238 (define bezier-sandwich ,bezier-sandwich)
239 (define dashed-line ,dashed-line)
240 (define dashed-slur ,dashed-slur)
241 (define hairpin ,hairpin)
242 (define end-output ,end-output)
243 (define experimental-on ,experimental-on)
244 (define filledbox ,filledbox)
245 (define font-def ,font-def)
246 (define font-switch ,font-switch)
247 (define header-end ,header-end)
248 (define lily-def ,lily-def)
249 (define font-load-command ,font-load-command)
250 (define header ,header)
251 (define invoke-char ,invoke-char)
252 (define invoke-dim1 ,invoke-dim1)
253 (define placebox ,placebox)
254 (define repeat-slash ,repeat-slash)
255 (define select-font ,select-font)
256 (define start-line ,start-line)
258 (define stop-line ,stop-line)
259 (define stop-last-line ,stop-line)
261 (define no-origin ,no-origin)
262 (define define-origin ,define-origin)
263 (define ez-ball ,ez-ball)
265 ((eq? action-name 'tuplet) tuplet)
266 ((eq? action-name 'beam) beam)
267 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
268 ((eq? action-name 'bracket) bracket)
269 ((eq? action-name 'char) char)
270 ((eq? action-name 'dashed-line) dashed-line)
271 ((eq? action-name 'dashed-slur) dashed-slur)
272 ((eq? action-name 'hairpin) hairpin)
273 ((eq? action-name 'experimental-on) experimental-on)
274 ((eq? action-name 'ez-ball) ez-ball)
275 ((eq? action-name 'filledbox) filledbox)
276 ((eq? action-name 'repeat-slash) repeat-slash)
277 ((eq? action-name 'select-font) select-font)
278 ((eq? action-name 'volta) volta)
279 (else (error "unknown tag -- PDF-SCM " action-name))
283 (define (scm-pdf-output)
284 (primitive-eval (pdf-scm 'all-definitions)))
287 ; scheme-program-name: "guile"