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

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

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

1 tpapp 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 tpapp 13 (defclass context ()
26     ((pointer :initform nil :initarg :pointer)
27     (width :initarg :width :reader get-width)
28 tpapp 17 (height :initarg :height :reader get-height)
29     (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30 tpapp 1
31 tpapp 17 (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 tpapp 13 (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 tpapp 17 :height (get-height surface)
44     :pixel-based-p (pixel-based-p surface))))
45 tpapp 13 ;; register finalizer
46     (let ((context-pointer (slot-value context 'pointer)))
47 tpapp 17 (tg:finalize context
48     #'(lambda ()
49     (cairo_destroy context-pointer))))
50 tpapp 13 ;; return context
51     context)))
52 tpapp 1
53     (defmethod destroy ((object context))
54     (with-slots (pointer) object
55     (when pointer
56     (cairo_destroy pointer)
57 tpapp 7 (setf pointer nil)))
58     ;; deregister finalizer
59 tpapp 17 (tg:cancel-finalization object))
60 tpapp 1
61 tpapp 13 (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 tpapp 7
73 tpapp 13 ;; 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 tpapp 6
79 tpapp 14 (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 tpapp 1 ;;;;
89     ;;;; default context and convenience macros
90     ;;;;
91    
92 tpapp 7 (defvar *context* nil "default cairo context")
93 tpapp 1
94 tpapp 17 (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 tpapp 1 (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 tpapp 8 (unless (eq ,status 'status-success)
116 tpapp 1 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
124     (with-context (context pointer)
125     (,(prepend-intern "cairo_" name) pointer ,@args))))
126 tpapp 1
127 tpapp 6 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
132     (with-context (context pointer)
133     (,(prepend-intern "cairo_" name) pointer ,@args))
134     (sync context)))
135 tpapp 6
136 tpapp 1 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
140     (with-context (context ,pointer)
141     ,@body)))
142 tpapp 1
143 tpapp 11 (defmacro define-many-with-default-context (&body args)
144 tpapp 1 "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 tpapp 6 (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 tpapp 1
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 tpapp 6 (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 tpapp 1
172     ;;;;
173     ;;;; simple functions using context
174     ;;;;
175    
176     (define-many-with-default-context
177 tpapp 11 (save)
178     (restore)
179 tpapp 1 (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 tpapp 6 (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 tpapp 15 ;;;; 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 tpapp 10 ;;;;
205 tpapp 11 ;;;; set colors using the cl-colors library
206 tpapp 10 ;;;;
207 tpapp 11
208 tpapp 10 (defgeneric set-source-color (color &optional context))
209    
210 tpapp 13 (defmethod set-source-color ((color rgb) &optional (context *context*))
211 tpapp 11 (with-slots (red green blue) color
212     (set-source-rgb red green blue context)))
213 tpapp 10
214 tpapp 13 (defmethod set-source-color ((color rgba) &optional (context *context*))
215 tpapp 11 (with-slots (red green blue alpha) color
216 tpapp 15 (set-source-rgba red green blue alpha context)))
217 tpapp 10
218 tpapp 13 (defmethod set-source-color ((color hsv) &optional (context *context*))
219 tpapp 11 (with-slots (red green blue) (hsv->rgb color)
220     (set-source-rgb red green blue context)))
221    
222    
223 tpapp 1 ;;;;
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 tpapp 6 (cairo_fill pointer)
245     (sync context))
246 tpapp 1
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 tpapp 13
280     ;;;;
281     ;;;; convenience functions for creating contexts directly
282     ;;;;
283    
284 tpapp 17 (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 tpapp 13 (define-create-context ps)
298     (define-create-context pdf)
299     (define-create-context svg)

  ViewVC Help
Powered by ViewVC 1.1.5