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

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Sat Aug 25 12:34:48 2007 UTC (6 years, 7 months ago) by tpapp
File size: 8383 byte(s)
with-sync-lock added, x11-example.lisp fixed
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
30 (defun create-context (surface)
31 (with-surface (surface pointer)
32 (let ((context (make-instance 'context
33 :pointer (cairo_create pointer)
34 :width (get-width surface)
35 :height (get-height surface))))
36 ;; register finalizer
37 (let ((context-pointer (slot-value context 'pointer)))
38 (finalize context
39 #'(lambda ()
40 (cairo_destroy context-pointer))))
41 ;; return context
42 context)))
43
44 (defmethod destroy ((object context))
45 (with-slots (pointer) object
46 (when pointer
47 (cairo_destroy pointer)
48 (setf pointer nil)))
49 ;; deregister finalizer
50 (cancel-finalization object))
51
52 (defgeneric sync (object)
53 (:documentation "Synchronize contents of the object with the
54 physical device if needed."))
55 (defgeneric sync-lock (object)
56 (:documentation "Suspend syncing (ie sync will have no effect) until
57 sync-unlock is called. Calls to sync-lock nest."))
58 (defgeneric sync-unlock (object)
59 (:documentation "Undo a call to sync-lock."))
60 (defgeneric sync-reset (object)
61 (:documentation "Undo all calls to sync, ie object will be
62 synced (if necessary) no matter how many times sync was called before."))
63
64 ;; most contexts don't need syncing
65 (defmethod sync ((object context)))
66 (defmethod sync-lock ((object context)))
67 (defmethod sync-unlock ((object context)))
68 (defmethod sync-reset ((object context)))
69
70 (defmacro with-sync-lock ((context) &body body)
71 "Lock sync for context for the duration of body. Protected against
72 nonlocal exits."
73 (once-only (context)
74 `(progn
75 (sync-lock ,context)
76 (unwind-protect (progn ,@body)
77 (sync-unlock ,context)))))
78
79 ;;;;
80 ;;;; default context and convenience macros
81 ;;;;
82
83 (defvar *context* nil "default cairo context")
84
85 (defmacro with-context ((context pointer) &body body)
86 "Execute body with pointer pointing to context, and check status."
87 (let ((status (gensym))
88 (pointer-name pointer))
89 `(with-slots ((,pointer-name pointer)) ,context
90 (if ,pointer-name
91 (multiple-value-prog1 (progn ,@body)
92 (let ((,status
93 (lookup-cairo-enum (cairo_status ,pointer-name) table-status)))
94 (unless (eq ,status 'status-success)
95 (warn "function returned with status ~a." ,status))))
96 (warn "context is not alive")))))
97
98 (defmacro define-with-default-context (name &rest args)
99 "Define cairo function with *context* as its first argument and
100 args as the rest, automatically mapping name to the appropriate
101 cairo function."
102 `(defun ,name (,@args &optional (context *context*))
103 (with-context (context pointer)
104 (,(prepend-intern "cairo_" name) pointer ,@args))))
105
106 (defmacro define-with-default-context-sync (name &rest args)
107 "Define cairo function with *context* as its first argument and
108 args as the rest, automatically mapping name to the appropriate
109 cairo function. sync will be called after the operation."
110 `(defun ,name (,@args &optional (context *context*))
111 (with-context (context pointer)
112 (,(prepend-intern "cairo_" name) pointer ,@args))
113 (sync context)))
114
115 (defmacro define-flexible ((name pointer &rest args) &body body)
116 "Like define-with-default context, but with arbitrary body,
117 pointer will point to the context."
118 `(defun ,name (,@args &optional (context *context*))
119 (with-context (context ,pointer)
120 ,@body)))
121
122 (defmacro define-many-with-default-context (&body args)
123 "Apply define-with-default context to a list. Each item is
124 itself a list, first element gives the function name, the rest
125 the arguments."
126 `(progn
127 ,@(loop for arglist in args
128 collect `(define-with-default-context ,(car arglist) ,@(cdr arglist)))))
129
130 (defmacro define-get-set (property)
131 "Define set-property and get-property functions."
132 `(progn
133 (define-with-default-context ,(prepend-intern "get-" property :replace-dash nil))
134 (define-with-default-context ,(prepend-intern "set-" property :replace-dash nil)
135 ,property)))
136
137 (defmacro define-get-set-using-table (property)
138 "Define set-property and get-property functions, where property
139 is looked up in table-property for conversion into Cairo's enum
140 constants."
141 `(progn
142 (define-flexible (,(prepend-intern "get-" property :replace-dash nil) pointer)
143 (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer)
144 ,(prepend-intern "table-" property :replace-dash nil)))
145 (define-flexible (,(prepend-intern "set-" property :replace-dash nil)
146 pointer ,property)
147 (,(prepend-intern "cairo_set_" property) pointer
148 (lookup-enum ,property ,(prepend-intern "table-"
149 property :replace-dash nil))))))
150
151 ;;;;
152 ;;;; simple functions using context
153 ;;;;
154
155 (define-many-with-default-context
156 (save)
157 (restore)
158 (push-group)
159 (pop-group)
160 (pop-group-to-source)
161 (set-source-rgb red green blue)
162 (set-source-rgba red green blue alpha)
163 (clip)
164 (clip-preserve)
165 (reset-clip)
166 (copy-page)
167 (show-page))
168
169 (define-with-default-context-sync fill-preserve)
170 (define-with-default-context-sync paint)
171 (define-with-default-context-sync paint-with-alpha alpha)
172 (define-with-default-context-sync stroke)
173 (define-with-default-context-sync stroke-preserve)
174
175 ;;;;
176 ;;;; set colors using the cl-colors library
177 ;;;;
178
179 (defgeneric set-source-color (color &optional context))
180
181 (defmethod set-source-color ((color rgb) &optional (context *context*))
182 (with-slots (red green blue) color
183 (set-source-rgb red green blue context)))
184
185 (defmethod set-source-color ((color rgba) &optional (context *context*))
186 (with-slots (red green blue alpha) color
187 (set-source-rgb red green blue alpha context)))
188
189 (defmethod set-source-color ((color hsv) &optional (context *context*))
190 (with-slots (red green blue) (hsv->rgb color)
191 (set-source-rgb red green blue context)))
192
193
194 ;;;;
195 ;;;; functions that get/set a property without any conversion
196 ;;;;
197
198 (define-get-set line-width)
199 (define-get-set miter-limit)
200 (define-get-set tolerance)
201
202 ;;;;
203 ;;;; functions that get/set a property using a lookup table
204 ;;;;
205
206 (define-get-set-using-table antialias)
207 (define-get-set-using-table fill-rule)
208 (define-get-set-using-table line-cap)
209 (define-get-set-using-table line-join)
210 (define-get-set-using-table operator)
211
212 ;; fill-path: it should simply be fill, but it is renamed so it does
213 ;; not clash with cl-user:fill
214 (define-flexible (fill-path pointer)
215 (cairo_fill pointer)
216 (sync context))
217
218 (define-flexible (set-dash pointer offset dashes)
219 (let ((num-dashes (length dashes)))
220 (with-foreign-object (dashes-pointer :double num-dashes)
221 (copy-double-vector-to-pointer (coerce dashes 'vector) dashes-pointer)
222 (cairo_set_dash pointer dashes-pointer num-dashes offset))))
223
224 (define-flexible (get-dash pointer)
225 "Return two values: dashes as a vector and the offset."
226 (let ((num-dashes (cairo_get_dash_count pointer)))
227 (with-foreign-objects ((dashes-pointer :double num-dashes)
228 (offset-pointer :double))
229 (cairo_get_dash pointer dashes-pointer offset-pointer)
230 (values (copy-pointer-to-double-vector num-dashes dashes-pointer)
231 (mem-ref offset-pointer :double)))))
232
233 (defmacro define-get-extents (name)
234 "Define functions that query two coordinate pairs."
235 `(define-flexible (,name pointer)
236 (with-foreign-objects ((x1 :double) (y1 :double)
237 (x2 :double) (y2 :double))
238 (,(prepend-intern "cairo_" name) pointer x1 y1 x2 y2)
239 (values (mem-ref x1 :double) (mem-ref y1 :double)
240 (mem-ref x2 :double) (mem-ref y2 :double)))))
241
242 (define-get-extents clip-extents)
243 (define-get-extents fill-extents)
244
245 (define-flexible (in-fill pointer x y)
246 (not (zerop (cairo_in_fill pointer x y))))
247
248 (define-flexible (in-stroke pointer x y)
249 (not (zerop (cairo_in_stroke pointer x y))))
250
251 ;;;;
252 ;;;; convenience functions for creating contexts directly
253 ;;;;
254
255 (define-create-context ps)
256 (define-create-context pdf)
257 (define-create-context svg)

  ViewVC Help
Powered by ViewVC 1.1.5