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

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 13 - (show annotations)
Wed Aug 22 16:13:14 2007 UTC (6 years, 7 months ago) by tpapp
File size: 8117 byte(s)
another major revamping of X11 code, also put exported symbols in package.lisp where they belong
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 ;;;;
71 ;;;; default context and convenience macros
72 ;;;;
73
74 (defvar *context* nil "default cairo context")
75
76 (defmacro with-context ((context pointer) &body body)
77 "Execute body with pointer pointing to context, and check status."
78 (let ((status (gensym))
79 (pointer-name pointer))
80 `(with-slots ((,pointer-name pointer)) ,context
81 (if ,pointer-name
82 (multiple-value-prog1 (progn ,@body)
83 (let ((,status
84 (lookup-cairo-enum (cairo_status ,pointer-name) table-status)))
85 (unless (eq ,status 'status-success)
86 (warn "function returned with status ~a." ,status))))
87 (warn "context is not alive")))))
88
89 (defmacro define-with-default-context (name &rest args)
90 "Define cairo function with *context* as its first argument and
91 args as the rest, automatically mapping name to the appropriate
92 cairo function."
93 `(defun ,name (,@args &optional (context *context*))
94 (with-context (context pointer)
95 (,(prepend-intern "cairo_" name) pointer ,@args))))
96
97 (defmacro define-with-default-context-sync (name &rest args)
98 "Define cairo function with *context* as its first argument and
99 args as the rest, automatically mapping name to the appropriate
100 cairo function. sync will be called after the operation."
101 `(defun ,name (,@args &optional (context *context*))
102 (with-context (context pointer)
103 (,(prepend-intern "cairo_" name) pointer ,@args))
104 (sync context)))
105
106 (defmacro define-flexible ((name pointer &rest args) &body body)
107 "Like define-with-default context, but with arbitrary body,
108 pointer will point to the context."
109 `(defun ,name (,@args &optional (context *context*))
110 (with-context (context ,pointer)
111 ,@body)))
112
113 (defmacro define-many-with-default-context (&body args)
114 "Apply define-with-default context to a list. Each item is
115 itself a list, first element gives the function name, the rest
116 the arguments."
117 `(progn
118 ,@(loop for arglist in args
119 collect `(define-with-default-context ,(car arglist) ,@(cdr arglist)))))
120
121 (defmacro define-get-set (property)
122 "Define set-property and get-property functions."
123 `(progn
124 (define-with-default-context ,(prepend-intern "get-" property :replace-dash nil))
125 (define-with-default-context ,(prepend-intern "set-" property :replace-dash nil)
126 ,property)))
127
128 (defmacro define-get-set-using-table (property)
129 "Define set-property and get-property functions, where property
130 is looked up in table-property for conversion into Cairo's enum
131 constants."
132 `(progn
133 (define-flexible (,(prepend-intern "get-" property :replace-dash nil) pointer)
134 (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer)
135 ,(prepend-intern "table-" property :replace-dash nil)))
136 (define-flexible (,(prepend-intern "set-" property :replace-dash nil)
137 pointer ,property)
138 (,(prepend-intern "cairo_set_" property) pointer
139 (lookup-enum ,property ,(prepend-intern "table-"
140 property :replace-dash nil))))))
141
142 ;;;;
143 ;;;; simple functions using context
144 ;;;;
145
146 (define-many-with-default-context
147 (save)
148 (restore)
149 (push-group)
150 (pop-group)
151 (pop-group-to-source)
152 (set-source-rgb red green blue)
153 (set-source-rgba red green blue alpha)
154 (clip)
155 (clip-preserve)
156 (reset-clip)
157 (copy-page)
158 (show-page))
159
160 (define-with-default-context-sync fill-preserve)
161 (define-with-default-context-sync paint)
162 (define-with-default-context-sync paint-with-alpha alpha)
163 (define-with-default-context-sync stroke)
164 (define-with-default-context-sync stroke-preserve)
165
166 ;;;;
167 ;;;; set colors using the cl-colors library
168 ;;;;
169
170 (defgeneric set-source-color (color &optional context))
171
172 (defmethod set-source-color ((color rgb) &optional (context *context*))
173 (with-slots (red green blue) color
174 (set-source-rgb red green blue context)))
175
176 (defmethod set-source-color ((color rgba) &optional (context *context*))
177 (with-slots (red green blue alpha) color
178 (set-source-rgb red green blue alpha context)))
179
180 (defmethod set-source-color ((color hsv) &optional (context *context*))
181 (with-slots (red green blue) (hsv->rgb color)
182 (set-source-rgb red green blue context)))
183
184
185 ;;;;
186 ;;;; functions that get/set a property without any conversion
187 ;;;;
188
189 (define-get-set line-width)
190 (define-get-set miter-limit)
191 (define-get-set tolerance)
192
193 ;;;;
194 ;;;; functions that get/set a property using a lookup table
195 ;;;;
196
197 (define-get-set-using-table antialias)
198 (define-get-set-using-table fill-rule)
199 (define-get-set-using-table line-cap)
200 (define-get-set-using-table line-join)
201 (define-get-set-using-table operator)
202
203 ;; fill-path: it should simply be fill, but it is renamed so it does
204 ;; not clash with cl-user:fill
205 (define-flexible (fill-path pointer)
206 (cairo_fill pointer)
207 (sync context))
208
209 (define-flexible (set-dash pointer offset dashes)
210 (let ((num-dashes (length dashes)))
211 (with-foreign-object (dashes-pointer :double num-dashes)
212 (copy-double-vector-to-pointer (coerce dashes 'vector) dashes-pointer)
213 (cairo_set_dash pointer dashes-pointer num-dashes offset))))
214
215 (define-flexible (get-dash pointer)
216 "Return two values: dashes as a vector and the offset."
217 (let ((num-dashes (cairo_get_dash_count pointer)))
218 (with-foreign-objects ((dashes-pointer :double num-dashes)
219 (offset-pointer :double))
220 (cairo_get_dash pointer dashes-pointer offset-pointer)
221 (values (copy-pointer-to-double-vector num-dashes dashes-pointer)
222 (mem-ref offset-pointer :double)))))
223
224 (defmacro define-get-extents (name)
225 "Define functions that query two coordinate pairs."
226 `(define-flexible (,name pointer)
227 (with-foreign-objects ((x1 :double) (y1 :double)
228 (x2 :double) (y2 :double))
229 (,(prepend-intern "cairo_" name) pointer x1 y1 x2 y2)
230 (values (mem-ref x1 :double) (mem-ref y1 :double)
231 (mem-ref x2 :double) (mem-ref y2 :double)))))
232
233 (define-get-extents clip-extents)
234 (define-get-extents fill-extents)
235
236 (define-flexible (in-fill pointer x y)
237 (not (zerop (cairo_in_fill pointer x y))))
238
239 (define-flexible (in-stroke pointer x y)
240 (not (zerop (cairo_in_stroke pointer x y))))
241
242 ;;;;
243 ;;;; convenience functions for creating contexts directly
244 ;;;;
245
246 (define-create-context ps)
247 (define-create-context pdf)
248 (define-create-context svg)

  ViewVC Help
Powered by ViewVC 1.1.5