1 ;;;; pdf.scm -- implement Scheme output routines for PDF.
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2001--2004 Stephen Peters <portnoy@portnoy.org>
8 ;currently no font commands; this is a helper for pdftex.scm.
10 (define-module (scm output-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 (ly:number-pair->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 blot)
56 (let ((ht (* slope width)))
57 (string-append (moveto 0 (- (/ thick 2)))
60 (lineto 0 (/ thick 2))
63 (define (brack-traject pair ds alpha)
64 (let ((alpha-rad (* alpha (/ 3.141592654 180))))
65 (cons (+ (car pair) (* (cos alpha-rad) ds))
66 (+ (cdr pair) (* (sin alpha-rad) ds)))))
68 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
69 (let* ((halfht (+ (/ height 2) thick))
70 (farpt (cons (+ thick arch_height)
71 (+ (- halfht arch_thick) arch_width)))
73 (string-append (moveto 0 0)
75 (lineto thick (- halfht arch_thick))
77 (brack-traject (cons thick
78 (- halfht arch_thick))
79 (* 0.4 arch_height) 0)
88 (brack-traject (cons (/ thick 2) halfht)
93 (string-append (setlinewidth (/ thick 2))
95 "q 1 0 0 -1 0 0 cm " ; flip coords
101 (invoke-char " show" i))
104 (define (dashed-slur thick dash lst)
105 (string-append (setlineparams)
106 "[ " (ly:number->string dash) " "
107 (ly:number->string (* 10 thick)) " ] 0 d "
109 (moveto-pair (car lst))
110 (apply curveto (cdr lst))
113 (define (dashed-line thick on off dx dy)
114 (string-append (setlineparams)
115 "[ " (ly:number->string on) " "
116 (ly:number->string off) " ] 0 d "
122 (define (repeat-slash width slope beamthick)
123 (let* ((height (/ beamthick slope))
124 (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
125 (string-append (moveto 0 0)
127 (rlineto width (* slope width))
132 (define (experimental-on) "")
134 (define (filledbox breadth width depth height)
135 (string-append (ly:number->string (- breadth)) " "
136 (ly:number->string (- depth)) " "
137 (ly:number->string (+ breadth width)) " "
138 (ly:number->string (+ depth height))
141 (define (round-filled-box breadth width depth height blotdiam)
142 (let* ((rad (/ blotdiam 2))
147 (string-append " 0 J "
148 (setlinewidth blotdiam)
153 (rlineto (- (+ b w)) 0)
154 (rlineto 0 (- (+ d h)))
157 ;; PDF doesn't have the nifty arc operator. This uses a fast
158 ;; approximation with two curves. It bulges out a bit more than a
159 ;; true circle should along the 45 degree axes, but most users won't
161 (define (dot x y radius)
162 (string-append (moveto (- x radius) y)
163 (curveto (- x radius) (+ y (* 1.3333 radius))
164 (+ x radius) (+ y (* 1.3333 radius))
166 (curveto (+ x radius) (- y (* 1.3333 radius))
167 (- x radius) (- y (* 1.3333 radius))
172 (define (round-filled-box breadth width depth height blot)
173 (filledbox breadth width depth height))
175 (define (font-def i s) "")
177 (define (font-switch i) "")
179 (define (header-end) "")
181 (define (lily-def key val) "")
183 (define (header creator generate) "")
185 (define (invoke-char s i)
187 "(\\" (ly:inexact->string i 8) ") " s " " ))
189 (define (placebox x y s) "")
191 (define (bezier-sandwich lst thick)
192 (string-append (setlinewidth thick)
193 (moveto-pair (list-ref lst 7))
194 (curveto-pairs (list-ref lst 4)
197 (lineto-pair (list-ref lst 3))
198 (curveto-pairs (list-ref lst 0)
202 (bezier-ending (list-ref lst 3) (list-ref lst 0) (list-ref lst 5))
203 (bezier-ending (list-ref lst 7) (list-ref lst 0) (list-ref lst 5))))
205 (define (bezier-ending z0 z1 z2)
213 (/ (sqrt (+ (* (- x1 x2) (- x1 x2))
214 (* (- y1 y2) (- y1 y2)))) 2))))
217 (define (start-system width height) "")
219 (define (stem breadth width depth height)
220 (filledbox breadth width depth height))
222 (define (stop-system) "")
226 (define (polygon points blotdiameter) "") ;; TODO
228 (define (draw-line thick fx fy tx ty)
229 (string-append (setlineparams)
235 (define (unknown) "\n unknown\n")
237 ; Problem here -- we're using /F18 for the font, but we don't know
238 ; for sure that that will exist.
240 (define (ez-ball ch letter-col ball-col)
241 (let ((origin (cons 0.45 0)))
242 (string-append (setgray 0)
244 (moveto-pair origin) (lineto-pair origin)
248 (moveto-pair origin) (lineto-pair origin)
254 "-0.28 -0.30 Td " ; move for text block
255 "[(" ch ")] TJ ET ")))
257 (define (define-origin a b c ) "")
258 (define (no-origin) "")
260 (define-public (pdf-output-expression expr port)
261 (display (eval expr this-module) port) )
265 ; scheme-program-name: "guile"