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>
8 ;currently no font commands; this is a helper for pdftex.scm.
10 (define-module (scm pdf))
13 (define this-module (current-module))
21 ; simple commands to store and update currentpoint. This makes the
22 ; other procedures simple rewrites of the PostScript code.
24 (define currentpoint (cons 0 0))
26 (string-append (number-pair->string currentpoint) " "))
28 (set! currentpoint (cons x y))
29 (string-append (showcp) "m "))
30 (define (moveto-pair pair)
31 (moveto (car pair) (cdr pair)))
33 (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
35 (set! currentpoint (cons x y))
36 (string-append (showcp) "l "))
37 (define (lineto-pair pair)
38 (lineto (car pair) (cdr pair)))
40 (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
41 (define (curveto x1 y1 x2 y2 x y)
42 (set! currentpoint (cons x y))
43 (string-append (ly:number->string x1) (ly:number->string y1)
44 (ly:number->string x2) (ly:number->string y2)
45 (ly:number->string x) (ly:number->string y) "c "))
46 (define (curveto-pairs pt1 pt2 pt)
47 (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
48 (define (closefill) "h f ")
49 (define (closestroke) "S ")
50 (define (setlinewidth w) (string-append (ly:number->string w) "w "))
51 (define (setgray g) (string-append (ly:number->string g) "g "))
52 (define (setlineparams) "1 j 1 J ")
54 (define (beam width slope thick)
55 (let ((ht (* slope width)))
56 (string-append (moveto 0 (- (/ thick 2)))
59 (lineto 0 (/ thick 2))
63 (string-append "% " s "\n"))
65 (define (brack-traject pair ds alpha)
66 (let ((alpha-rad (* alpha (/ 3.141592654 180))))
67 (cons (+ (car pair) (* (cos alpha-rad) ds))
68 (+ (cdr pair) (* (sin alpha-rad) ds)))))
70 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
71 (let* ((halfht (+ (/ height 2) thick))
72 (farpt (cons (+ thick arch_height)
73 (+ (- halfht arch_thick) arch_width)))
75 (string-append (moveto 0 0)
77 (lineto thick (- halfht arch_thick))
79 (brack-traject (cons thick
80 (- halfht arch_thick))
81 (* 0.4 arch_height) 0)
90 (brack-traject (cons (/ thick 2) halfht)
95 (string-append (setlinewidth (/ thick 2))
97 "q 1 0 0 -1 0 0 cm " ; flip coords
103 (invoke-char " show" i))
106 (define (dashed-slur thick dash l)
107 (string-append (setlineparams)
108 "[ " (ly:number->string dash) " "
109 (ly:number->string (* 10 thick)) " ] 0 d "
111 (moveto-pair (car l))
112 (apply curveto (cdr l))
115 (define (dashed-line thick on off dx dy)
116 (string-append (setlineparams)
117 "[ " (ly:number->string on) " "
118 (ly:number->string off) " ] 0 d "
124 (define (repeat-slash width slope beamthick)
125 (let* ((height (/ beamthick slope))
126 (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
127 (string-append (moveto 0 0)
129 (rlineto width (* slope width))
133 (define (end-output) "")
135 (define (experimental-on) "")
137 (define (filledbox breadth width depth height)
138 (string-append (ly:number->string (- breadth))
139 (ly:number->string (- depth))
140 (ly:number->string (+ breadth width))
141 (ly:number->string (+ depth height))
144 (define (roundfilledbox breadth width depth height blotdiam)
145 (let* ((rad (/ blotdiam 2))
150 (string-append " 0 J "
151 (setlinewidth blotdiam)
156 (rlineto (- (+ b w)) 0)
157 (rlineto 0 (- (+ d h)))
160 ;; PDF doesn't have the nifty arc operator. This uses a fast
161 ;; approximation with two curves. It bulges out a bit more than a
162 ;; true circle should along the 45 degree axes, but most users won't
164 (define (dot x y radius)
165 (string-append (moveto (- x radius) y)
166 (curveto (- x radius) (+ y (* 1.3333 radius))
167 (+ x radius) (+ y (* 1.3333 radius))
169 (curveto (+ x radius) (- y (* 1.3333 radius))
170 (- x radius) (- y (* 1.3333 radius))
175 (define (roundfilledbox breadth width depth height blot)
176 (filledbox breadth width depth height))
178 (define (font-def i s) "")
180 (define (font-switch i) "")
182 (define (header-end) "")
184 (define (lily-def key val) "")
186 (define (header creator generate) "")
188 (define (invoke-char s i)
190 "(\\" (inexact->string i 8) ") " s " " ))
192 (define (placebox x y s) "")
194 (define (bezier-bow l thick)
195 (bezier-sandwich l thick))
197 (define (bezier-sandwich l thick)
198 (string-append (setlinewidth thick)
199 (moveto-pair (list-ref l 7))
200 (curveto-pairs (list-ref l 4)
203 (lineto-pair (list-ref l 3))
204 (curveto-pairs (list-ref l 0)
208 (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
209 (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
211 (define (bezier-ending z0 z1 z2)
219 (/ (sqrt (+ (* (- x1 x2) (- x1 x2))
220 (* (- y1 y2) (- y1 y2)))) 2))))
223 (define (start-system width height) "")
225 (define (stem breadth width depth height)
226 (filledbox breadth width depth height))
228 (define (stop-system) "")
232 (define (polygon points blotdiameter) "") ;; TODO
234 (define (draw-line thick fx fy tx ty)
235 (string-append (setlineparams)
241 (define (unknown) "\n unknown\n")
243 ; Problem here -- we're using /F18 for the font, but we don't know
244 ; for sure that that will exist.
246 (define (ez-ball ch letter-col ball-col)
247 (let ((origin (cons 0.45 0)))
248 (string-append (setgray 0)
250 (moveto-pair origin) (lineto-pair origin)
254 (moveto-pair origin) (lineto-pair origin)
260 "-0.28 -0.30 Td " ; move for text block
261 "[(" ch ")] TJ ET ")))
263 (define (define-origin a b c ) "")
264 (define (no-origin) "")
266 (define-public (pdf-output-expression expr port)
267 (display (eval expr this-module) port) )
271 ; scheme-program-name: "guile"