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)
14 (define this-module (current-module))
22 ; simple commands to store and update currentpoint. This makes the
23 ; other procedures simple rewrites of the PostScript code.
25 (define currentpoint (cons 0 0))
27 (string-append (control->string currentpoint) " "))
29 (set! currentpoint (cons x y))
30 (string-append (showcp) "m "))
31 (define (moveto-pair pair)
32 (moveto (car pair) (cdr pair)))
34 (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
36 (set! currentpoint (cons x y))
37 (string-append (showcp) "l "))
38 (define (lineto-pair pair)
39 (lineto (car pair) (cdr pair)))
41 (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
42 (define (curveto x1 y1 x2 y2 x y)
43 (set! currentpoint (cons x y))
44 (string-append (ly-number->string x1) (ly-number->string y1)
45 (ly-number->string x2) (ly-number->string y2)
46 (ly-number->string x) (ly-number->string y) "c "))
47 (define (curveto-pairs pt1 pt2 pt)
48 (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
49 (define (closefill) "h f ")
50 (define (closestroke) "S ")
51 (define (setlinewidth w) (string-append (ly-number->string w) "w "))
52 (define (setgray g) (string-append (ly-number->string g) "g "))
53 (define (setlineparams) "1 j 1 J ")
55 (define (beam width slope thick)
56 (let ((ht (* slope width)))
57 (string-append (moveto 0 (- (/ thick 2)))
60 (lineto 0 (/ thick 2))
64 (string-append "% " s "\n"))
66 (define (brack-traject pair ds alpha)
67 (let ((alpha-rad (* alpha (/ 3.141592654 180))))
68 (cons (+ (car pair) (* (cos alpha-rad) ds))
69 (+ (cdr pair) (* (sin alpha-rad) ds)))))
71 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
72 (let* ((halfht (+ (/ height 2) thick))
73 (farpt (cons (+ thick arch_height)
74 (+ (- halfht arch_thick) arch_width)))
76 (string-append (moveto 0 0)
78 (lineto thick (- halfht arch_thick))
80 (brack-traject (cons thick
81 (- halfht arch_thick))
82 (* 0.4 arch_height) 0)
91 (brack-traject (cons (/ thick 2) halfht)
96 (string-append (setlinewidth (/ thick 2))
98 "q 1 0 0 -1 0 0 cm " ; flip coords
104 (invoke-char " show" i))
107 (define (dashed-slur thick dash l)
108 (string-append (setlineparams)
109 "[ " (ly-number->string dash) " "
110 (ly-number->string (* 10 thick)) " ] 0 d "
112 (moveto-pair (car l))
113 (apply curveto (cdr l))
116 (define (dashed-line thick on off dx dy)
117 (string-append (setlineparams)
118 "[ " (ly-number->string on) " "
119 (ly-number->string off) " ] 0 d "
125 (define (repeat-slash width slope beamthick)
126 (let* ((height (/ beamthick slope))
127 (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
128 (string-append (moveto 0 0)
130 (rlineto width (* slope width))
134 (define (end-output) "")
136 (define (experimental-on) "")
138 (define (filledbox breadth width depth height)
139 (string-append (ly-number->string (- breadth))
140 (ly-number->string (- depth))
141 (ly-number->string (+ breadth width))
142 (ly-number->string (+ depth height))
145 (define (roundfilledbox breadth width depth height blotdiam)
146 (let* ((rad (/ blotdiam 2))
151 (string-append " 0 J "
152 (setlinewidth blotdiam)
157 (rlineto (- (+ b w)) 0)
158 (rlineto 0 (- (+ d h)))
161 ;; PDF doesn't have the nifty arc operator. This uses a fast
162 ;; approximation with two curves. It bulges out a bit more than a
163 ;; true circle should along the 45 degree axes, but most users won't
165 (define (dot x y radius)
166 (string-append (moveto (- x radius) y)
167 (curveto (- x radius) (+ y (* 1.3333 radius))
168 (+ x radius) (+ y (* 1.3333 radius))
170 (curveto (+ x radius) (- y (* 1.3333 radius))
171 (- x radius) (- y (* 1.3333 radius))
176 (define (roundfilledbox breadth width depth height blot)
177 (filledbox breadth width depth height))
179 (define (font-def i s) "")
181 (define (font-switch i) "")
183 (define (header-end) "")
185 (define (lily-def key val) "")
187 (define (header creator generate) "")
189 (define (invoke-char s i)
191 "(\\" (inexact->string i 8) ") " s " " ))
193 (define (placebox x y s) "")
195 (define (bezier-bow l thick)
196 (bezier-sandwich l thick))
198 (define (bezier-sandwich l thick)
199 (string-append (setlinewidth thick)
200 (moveto-pair (list-ref l 7))
201 (curveto-pairs (list-ref l 4)
204 (lineto-pair (list-ref l 3))
205 (curveto-pairs (list-ref l 0)
209 (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
210 (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
212 (define (bezier-ending z0 z1 z2)
220 (/ (sqrt (+ (* (- x1 x2) (- x1 x2))
221 (* (- y1 y2) (- y1 y2)))) 2))))
224 (define (start-system height) "")
226 (define (stem breadth width depth height)
227 (filledbox breadth width depth height))
229 (define (stop-system) "")
233 (define (draw-line thick fx fy tx ty)
234 (string-append (setlineparams)
240 (define (unknown) "\n unknown\n")
242 ; Problem here -- we're using /F18 for the font, but we don't know
243 ; for sure that that will exist.
245 (define (ez-ball ch letter-col ball-col)
246 (let ((origin (cons 0.45 0)))
247 (string-append (setgray 0)
249 (moveto-pair origin) (lineto-pair origin)
253 (moveto-pair origin) (lineto-pair origin)
259 "-0.28 -0.30 Td " ; move for text block
260 "[(" ch ")] TJ ET ")))
262 (define (define-origin a b c ) "")
263 (define (no-origin) "")
265 (define my-eval-in-module eval)
267 (if (or (equal? (minor-version) "4.1")
268 (equal? (minor-version) "4")
269 (equal? (minor-version) "3.4"))
270 (set! my-eval-in-module eval-in-module))
272 (define-public (pdf-output-expression expr port)
273 (display (my-eval-in-module expr this-module) port) )
277 ; scheme-program-name: "guile"