/[cl-cairo2]/context.lisp
ViewVC logotype

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Sun Mar 23 22:58:24 2008 UTC (6 years ago) by tpapp
File size: 10032 byte(s)
Several small changes:

- dependence on trivial-garbage for finalizer code
- fixes in examples/Makefile

1 (in-package :cl-cairo2)
2
3 ;;;;
4 ;;;; Notes
5 ;;;;
6 ;;;; need to write:
7 ;;;; cairo-get-target
8 ;;;; push-group-with-content
9 ;;;; get-group-target
10 ;;;; set-source
11 ;;;; set-source-surface
12 ;;;; get-source
13 ;;;; mask
14 ;;;; mask-surface
15 ;;;;
16 ;;;;
17 ;;;; not sure anyone needs:
18 ;;;; get/set-user-data
19 ;;;; get-reference-count
20
21 ;;;;
22 ;;;; context class
23 ;;;;
24
25 (defclass context ()
26 ((pointer :initform nil :initarg :pointer)
27 (width :initarg :width :reader get-width)
28 (height :initarg :height :reader get-height)
29 (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30
31 (defmethod print-object ((obj context) stream)
32 "Print a canvas object."
33 (print-unreadable-object (obj stream :type t)
34 (with-slots (pointer width height pixel-based-p) obj
35 (format stream "pointer: ~a, width: ~a, height: ~a, pixel-based-p: ~a"
36 pointer width height pixel-based-p))))
37
38 (defun create-context (surface)
39 (with-surface (surface pointer)
40 (let ((context (make-instance 'context
41 :pointer (cairo_create pointer)
42 :width (get-width surface)
43 :height (get-height surface)
44 :pixel-based-p (pixel-based-p surface))))
45 ;; register finalizer
46 (let ((context-pointer (slot-value context 'pointer)))
47 (tg:finalize context
48 #'(lambda ()
49 (cairo_destroy context-pointer))))
50 ;; return context
51 context)))
52
53 (defmethod destroy ((object context))
54 (with-slots (pointer) object
55 (when pointer
56 (cairo_destroy pointer)
57 (setf pointer nil)))
58 ;; deregister finalizer
59 (tg:cancel-finalization object))
60
61 (defgeneric sync (object)
62 (:documentation "Synchronize contents of the object with the
63 physical device if needed."))
64 (defgeneric sync-lock (object)
65 (:documentation "Suspend syncing (ie sync will have no effect) until
66 sync-unlock is called. Calls to sync-lock nest."))
67 (defgeneric sync-unlock (object)
68 (:documentation "Undo a call to sync-lock."))
69 (defgeneric sync-reset (object)
70 (:documentation "Undo all calls to sync, ie object will be
71 synced (if necessary) no matter how many times sync was called before."))
72
73 ;; most contexts don't need syncing
74 (defmethod sync ((object context)))
75 (defmethod sync-lock ((object context)))
76 (defmethod sync-unlock ((object context)))
77 (defmethod sync-reset ((object context)))
78
79 (defmacro with-sync-lock ((context) &body body)
80 "Lock sync for context for the duration of body. Protected against
81 nonlocal exits."
82 (once-only (context)
83 `(progn
84 (sync-lock ,context)
85 (unwind-protect (progn ,@body)
86 (sync-unlock ,context)))))
87
88 ;;;;
89 ;;;; default context and convenience macros
90 ;;;;
91
92 (defvar *context* nil "default cairo context")
93
94 (defmacro with-png-file ((filename format width height) &body body)
95 "Execute the body with context bound to a newly created png
96 file, and close it after executing body."
97 (let ((surface-name (gensym)))
98 `(let* ((,surface-name (create-image-surface ,format ,width ,height))
99 (*context* (create-context ,surface-name)))
100 (progn
101 ,@body
102 (surface-write-to-png ,surface-name ,filename)
103 (destroy ,surface-name)
104 (destroy *context*)))))
105
106 (defmacro with-context ((context pointer) &body body)
107 "Execute body with pointer pointing to context, and check status."
108 (let ((status (gensym))
109 (pointer-name pointer))
110 `(with-slots ((,pointer-name pointer)) ,context
111 (if ,pointer-name
112 (multiple-value-prog1 (progn ,@body)
113 (let ((,status
114 (lookup-cairo-enum (cairo_status ,pointer-name) table-status)))
115 (unless (eq ,status 'status-success)
116 (warn "function returned with status ~a." ,status))))
117 (warn "context is not alive")))))
118
119 (defmacro define-with-default-context (name &rest args)
120 "Define cairo function with *context* as its first argument and
121 args as the rest, automatically mapping name to the appropriate
122 cairo function."
123 `(defun ,name (,@args &optional (context *context*))
124 (with-context (context pointer)
125 (,(prepend-intern "cairo_" name) pointer ,@args))))
126
127 (defmacro define-with-default-context-sync (name &rest args)
128 "Define cairo function with *context* as its first argument and
129 args as the rest, automatically mapping name to the appropriate
130 cairo function. sync will be called after the operation."
131 `(defun ,name (,@args &optional (context *context*))
132 (with-context (context pointer)
133 (,(prepend-intern "cairo_" name) pointer ,@args))
134 (sync context)))
135
136 (defmacro define-flexible ((name pointer &rest args) &body body)
137 "Like define-with-default context, but with arbitrary body,
138 pointer will point to the context."
139 `(defun ,name (,@args &optional (context *context*))
140 (with-context (context ,pointer)
141 ,@body)))
142
143 (defmacro define-many-with-default-context (&body args)
144 "Apply define-with-default context to a list. Each item is
145 itself a list, first element gives the function name, the rest
146 the arguments."
147 `(progn
148 ,@(loop for arglist in args
149 collect `(define-with-default-context ,(car arglist) ,@(cdr arglist)))))
150
151 (defmacro define-get-set (property)
152 "Define set-property and get-property functions."
153 `(progn
154 (define-with-default-context ,(prepend-intern "get-" property :replace-dash nil))
155 (define-with-default-context ,(prepend-intern "set-" property :replace-dash nil)
156 ,property)))
157
158 (defmacro define-get-set-using-table (property)
159 "Define set-property and get-property functions, where property
160 is looked up in table-property for conversion into Cairo's enum
161 constants."
162 `(progn
163 (define-flexible (,(prepend-intern "get-" property :replace-dash nil) pointer)
164 (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer)
165 ,(prepend-intern "table-" property :replace-dash nil)))
166 (define-flexible (,(prepend-intern "set-" property :replace-dash nil)
167 pointer ,property)
168 (,(prepend-intern "cairo_set_" property) pointer
169 (lookup-enum ,property ,(prepend-intern "table-"
170 property :replace-dash nil))))))
171
172 ;;;;
173 ;;;; simple functions using context
174 ;;;;
175
176 (define-many-with-default-context
177 (save)
178 (restore)
179 (push-group)
180 (pop-group)
181 (pop-group-to-source)
182 (set-source-rgb red green blue)
183 (set-source-rgba red green blue alpha)
184 (clip)
185 (clip-preserve)
186 (reset-clip)
187 (copy-page)
188 (show-page))
189
190 (define-with-default-context-sync fill-preserve)
191 (define-with-default-context-sync paint)
192 (define-with-default-context-sync paint-with-alpha alpha)
193 (define-with-default-context-sync stroke)
194 (define-with-default-context-sync stroke-preserve)
195
196 ;;;; get-target
197
198 (defun get-target (context)
199 "Obtain the target surface of a given context. Width and height
200 will be nil, as cairo can't provide that in general."
201 (new-surface-with-check (cairo_get_target (slot-value context 'pointer))
202 nil nil))
203
204 ;;;;
205 ;;;; set colors using the cl-colors library
206 ;;;;
207
208 (defgeneric set-source-color (color &optional context))
209
210 (defmethod set-source-color ((color rgb) &optional (context *context*))
211 (with-slots (red green blue) color
212 (set-source-rgb red green blue context)))
213
214 (defmethod set-source-color ((color rgba) &optional (context *context*))
215 (with-slots (red green blue alpha) color
216 (set-source-rgba red green blue alpha context)))
217
218 (defmethod set-source-color ((color hsv) &optional (context *context*))
219 (with-slots (red green blue) (hsv->rgb color)
220 (set-source-rgb red green blue context)))
221
222
223 ;;;;
224 ;;;; functions that get/set a property without any conversion
225 ;;;;
226
227 (define-get-set line-width)
228 (define-get-set miter-limit)
229 (define-get-set tolerance)
230
231 ;;;;
232 ;;;; functions that get/set a property using a lookup table
233 ;;;;
234
235 (define-get-set-using-table antialias)
236 (define-get-set-using-table fill-rule)
237 (define-get-set-using-table line-cap)
238 (define-get-set-using-table line-join)
239 (define-get-set-using-table operator)
240
241 ;; fill-path: it should simply be fill, but it is renamed so it does
242 ;; not clash with cl-user:fill
243 (define-flexible (fill-path pointer)
244 (cairo_fill pointer)
245 (sync context))
246
247 (define-flexible (set-dash pointer offset dashes)
248 (let ((num-dashes (length dashes)))
249 (with-foreign-object (dashes-pointer :double num-dashes)
250 (copy-double-vector-to-pointer (coerce dashes 'vector) dashes-pointer)
251 (cairo_set_dash pointer dashes-pointer num-dashes offset))))
252
253 (define-flexible (get-dash pointer)
254 "Return two values: dashes as a vector and the offset."
255 (let ((num-dashes (cairo_get_dash_count pointer)))
256 (with-foreign-objects ((dashes-pointer :double num-dashes)
257 (offset-pointer :double))
258 (cairo_get_dash pointer dashes-pointer offset-pointer)
259 (values (copy-pointer-to-double-vector num-dashes dashes-pointer)
260 (mem-ref offset-pointer :double)))))
261
262 (defmacro define-get-extents (name)
263 "Define functions that query two coordinate pairs."
264 `(define-flexible (,name pointer)
265 (with-foreign-objects ((x1 :double) (y1 :double)
266 (x2 :double) (y2 :double))
267 (,(prepend-intern "cairo_" name) pointer x1 y1 x2 y2)
268 (values (mem-ref x1 :double) (mem-ref y1 :double)
269 (mem-ref x2 :double) (mem-ref y2 :double)))))
270
271 (define-get-extents clip-extents)
272 (define-get-extents fill-extents)
273
274 (define-flexible (in-fill pointer x y)
275 (not (zerop (cairo_in_fill pointer x y))))
276
277 (define-flexible (in-stroke pointer x y)
278 (not (zerop (cairo_in_stroke pointer x y))))
279
280 ;;;;
281 ;;;; convenience functions for creating contexts directly
282 ;;;;
283
284 (defmacro define-create-context (type)
285 `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
286 (filename width height)
287 "Create a surface, then a context for a file, then
288 destroy (dereference) the surface. The user only needs to
289 destroy the context when done."
290 (let* ((surface (,(prepend-intern "create-"
291 type :replace-dash nil :suffix "-surface")
292 filename width height))
293 (context (create-context surface)))
294 (destroy surface)
295 context)))
296
297 (define-create-context ps)
298 (define-create-context pdf)
299 (define-create-context svg)

  ViewVC Help
Powered by ViewVC 1.1.5