source: project/release/4/fps/branches/cairo-backend/cairo-backend.scm @ 25696

Last change on this file since 25696 was 25696, checked in by Christian Kellermann, 9 years ago

fps (cairo): concatenation added, clipping still is somewhat odd

File size: 8.1 KB
Line 
1;;;; cairo-backend.scm - render to a cairo surface
2
3(use cairo miscmacros)
4
5(define-syntax oink
6  (syntax-rules ()
7    ((_ name)
8     (lambda args
9       (print 'name ": " args)
10       '#(42)))))
11
12
13(define surface
14  (cairo-pdf-surface-create
15   "bla.pdf"
16   595
17   842))
18
19(define ctx (cairo-create surface))
20
21(define tms '())
22
23
24(define (cairo-channel  . options)
25  (make-channel
26
27   ;; interface
28   #f;filename
29
30   ;; resources
31   (cairo-translate ctx 0 842)
32
33   (make-default-style)                 ; current style
34   #f                                   ; current font
35   (lambda (c) c)                       ; current colormap function
36   #f                                   ; current drawing method
37   #f                                   ; current pt
38
39   CAIRO-moveto                         ; move to a point
40   CAIRO-line                                   ; construct a line
41   CAIRO-rect                                   ; construct a rectangle
42   CAIRO-arc                                    ; construct an arc or circle
43   (oink CAIRO-tangent-arc)                             ; construct a tangent arc
44   CAIRO-curve                          ; construct a bezier curve
45   (oink PScharpath)                    ; construct a charpath
46   (oink PSglyphnamepath)     ; construct a charpath given a glyphname
47   CAIRO-show                                   ; render glyphs in string
48   (oink PSglyphshow)         ; render glyphs by glyphname
49   CAIRO-close-path                           ; close a path by appending line from end to start pt
50   (oink CAIRO-stroke-outline-path)
51
52   CAIRO-savetm ; push the current TM onto the stack       
53   CAIRO-restoretm      ; pop the TM off the stack                 
54   (oink CAIRO-savegstate)      ; push the current gstate onto the stack 
55   (oink CAIRO-restoregstate) ; pop the gstate off the stack               
56   CAIRO-concat   ; change the current TM                   
57
58   CAIRO-setcolor                ; change the current color               
59   CAIRO-setlinewidth ; change the current linewidth             
60   CAIRO-setlinejoin     ; change the current line join setting   
61   CAIRO-setlinecap      ; change the current line cap setting   
62   CAIRO-setmiterlimit    ; change the current miter limit setting
63   CAIRO-setdash             ; change the current cash setting   
64
65   CAIRO-selectfont          ; change the current font selection     
66
67   CAIRO-stroke-or-fill                                 ; either stroke or fill       
68   (oink CAIRO-clip)                    ; clip picture with path     
69   CAIRO-image                  ; render the bitmap image     
70   (oink CAIRO-imagemask)                       ; render the bitmap image mask
71
72   CAIRO-show-page
73   (oink CAIRO-read-show-options) ; deal with options presented with
74                                        ; show call
75   (oink CAIRO-check-picture-resources)   ; check resources required by a
76                                        ; picture (fonts) at show time
77 
78   CAIRO-close-channel))
79
80(define (show/cairo-channel picture . options)
81  (let ((channel (apply cairo-channel options)))
82    (show channel picture)
83    (close-channel channel)))
84
85(define (CAIRO-rect p w h method _)
86  (print "rect")
87  (cairo-rectangle ctx (pt:x p) (pt:y p) w h)
88  (case method
89    ((stroke-show stroke-stroke stroke-fill)
90     (cairo-stroke ctx))
91    ((fill-show fill-stroke fill-fill)
92     (cairo-fill ctx))))
93
94(define (CAIRO-moveto newpt _)
95  (print "moveto")
96  (cairo-move-to ctx (pt:x newpt) (pt:y newpt)))
97
98(define (CAIRO-line pts _)
99  (print "line")
100  (for-each (lambda (p)
101              (cairo-line-to ctx (pt:x p) (pt:y p)))
102            pts))
103
104(define (CAIRO-arc center radius start-ang end-ang _)
105  (print "oink")
106  (cairo-arc
107   ctx
108   (pt:x center)
109   (pt:y center)
110   radius
111   (rad->deg start-ang)
112   (rad->deg end-ang)))
113
114#;
115(define (CAIRO-tangent-arc pt1 pt2 pt3 radius _)
116  (print "tangent-arc")
117  (cairo-arc-negative
118   ctx
119   (pt1:x pt1)
120   (pt1:y pt1)
121   radius
122   (rad->deg start-ang)
123   (rad->deg end-ang)))
124
125(define (CAIRO-curve pt1 pt2 pt3 radius port)
126  (cairo-curve-to ctx
127               (pt:x pt1)
128               (pt:y pt1)
129               (pt:x pt2)
130               (pt:y pt2)
131               (pt:x pt3)
132               (pt:y pt3)) ; XXX this is plain wrong...
133 )
134
135(define (CAIRO-show str _)
136  (print "show")
137  (cairo-show-text ctx str))
138
139(define (CAIRO-close-path _)
140  (print "close-path")
141  (cairo-close-path ctx))
142
143(define (CAIRO-savetm _)
144  (print "savetm")
145  (push! (cairo-get-matrix ctx) tms))
146
147(define (CAIRO-restoretm _)
148  (print "restoretm")
149  (let ((m (pop! tms)))
150    (cairo-set-matrix ctx m)
151    (free m)))
152
153#;
154(define-syntax ?
155  (syntax-rules (<= <)
156    ((_ a <= b < c res ...)
157     ((and (<= a b) (< b c)) res ...))))
158
159#;
160(define (hsb->rgb col)
161  (let* ((h (hsb:h col))
162         (c (* h
163               (hsb:s col)))
164         (h2 (/ (hsb:b col) 60))
165         (x (* c (- 1 (abs (- (modulo h2 2) 1)))))
166         (m (- (hsb:b col) c)))
167    (map (cut + m <>)
168         (cond (? 0 <= h2 < 1 (list c x 0))
169               (? 1 <= h2 < 2 (list x c 0))
170               (? 2 <= h2 < 3 (list 0 c x))
171               (? 3 <= h2 < 4 (list 0 x c))
172               (? 4 <= h2 < 5 (list x 0 c))
173               (? 5 <= h2 < 6 (list c 0 x))
174               (else '(0 0 0))))))
175
176(define (CAIRO-setlinewidth val _)
177  (cairo-set-line-width ctx val))
178
179(define (CAIRO-setlinejoin val _)
180  (cairo-set-line-join ctx
181                       (case val
182                         ((miter) CAIRO_LINE_JOIN_MITER)
183                         ((round) CAIRO_LINE_JOIN_ROUND)
184                         ((bevel) CAIRO_LINE_JOIN_BEVEL)
185                         (else (error "illegal setlinejoin val " val)))))
186
187(define (CAIRO-setlinecap val _)
188  (cairo-set-line-cap ctx
189                      (case val
190                        ((butt) CAIRO_LINE_CAP_BUTT)
191                        ((round) CAIRO_LINE_CAP_ROUND)
192                        ((project-square) CAIRO_LINE_CAP_SQUARE)
193                        (else (error "Illegal setline cap val " val)))))
194
195(define (CAIRO-setmiterlimit val _)
196  (cairo-set-miter-limit ctx val))
197
198(define (CAIRO-setdash pattern offset _)
199  (cairo-set-dash ctx (list->f64vector (vector->list pattern)) (vector-length pattern) offset))
200
201(define (CAIRO-concat obj _)
202(let ((operand (instance:operand obj)))
203  (cond ((pt? operand)
204 ; this is ugly, I invert the Y axis due to the swapped origing of fps and cairo
205         (cairo-translate ctx (pt:x operand) (- (pt:y operand)))
206         (printf " ~a ~a tra~%" 
207                 (PSnum (pt:x operand)) (PSnum (pt:y operand))))
208        ((list?  operand)
209         (cairo-scale ctx (car operand) (cadr operand))
210         (printf " ~a ~a sca~%" 
211                 (PSnum (car operand)) (PSnum (cadr operand))))
212        ((number? operand)
213         (cairo-rotate ctx operand)
214         (printf " ~a rot~%" 
215                 (PSnum (rad->deg operand))))
216        ((matrix? operand) 
217         (cairo-transform/matrix ctx operand)
218         (printf " ~a cc~%" 
219                 (PSmatrix operand)))
220        (else (error PSconcat operand
221                     "Argument is not a transformation operand")))))
222
223(define (CAIRO-setcolor c _)
224  (print "set color " c)
225  (cond ((rgb? c) (cairo-set-source-rgb ctx
226                                        (rgb:r c)
227                                        (rgb:g c)
228                                        (rgb:b c)))
229        ((hsb? c) (let ((c2 (hsb->rgb (hsb:h c)
230                                      (hsb:s c)
231                                      (hsb:b c))))
232                    (cairo-set-source-rgb ctx
233                                          (rgb:r c2)
234                                          (rgb:g c2)
235                                          (rgb:b c2))))
236        ((cmyk? c) (error "not supported"))
237        ((gray? c) (error "not supported"))
238        (else (error PSsetcolor c
239                     "Argument passed to PSsetcolor is not a color"))))
240
241(define (CAIRO-selectfont font _)
242  (cairo-select-font-face ctx (font:fontname font) CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)
243  (cairo-set-font-size ctx (font:fontsize font)))
244
245(define (CAIRO-stroke-or-fill method _)
246  (print "stroke or fill?")
247  (if (not (eq? method 'show))
248      (case method
249        ((stroke-show stroke-stroke stroke-fill)
250         (cairo-stroke ctx))
251        ((fill-show fill-stroke fill-fill)
252         (cairo-fill ctx)))))
253
254(define (CAIRO-clip _)
255  (print "clip")
256  (cairo-clip ctx))
257
258(define (CAIRO-image row col resolution colorspace color-array _)
259  (print "image unimplemented")
260  (void))
261
262(define (CAIRO-show-page chan)
263  (print "show page")
264  (cairo-surface-show-page surface))
265
266(define (CAIRO-close-channel chan)
267  (print "close channel")
268  (cairo-surface-finish surface))
Note: See TracBrowser for help on using the repository browser.