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

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

fps: initial nonfunctional cairo backend

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