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

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 15 - (hide annotations)
Thu Dec 20 13:05:07 2007 UTC (6 years, 4 months ago) by tpapp
File size: 8641 byte(s)
reorganization, bugfixes
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     (height :initarg :height :reader get-height)))
29 tpapp 1
30 tpapp 13 (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 tpapp 1
44     (defmethod destroy ((object context))
45     (with-slots (pointer) object
46     (when pointer
47     (cairo_destroy pointer)
48 tpapp 7 (setf pointer nil)))
49     ;; deregister finalizer
50     (cancel-finalization object))
51 tpapp 1
52 tpapp 13 (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 tpapp 7
64 tpapp 13 ;; 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 tpapp 6
70 tpapp 14 (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 tpapp 1 ;;;;
80     ;;;; default context and convenience macros
81     ;;;;
82    
83 tpapp 7 (defvar *context* nil "default cairo context")
84 tpapp 1
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 tpapp 8 (unless (eq ,status 'status-success)
95 tpapp 1 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
103     (with-context (context pointer)
104     (,(prepend-intern "cairo_" name) pointer ,@args))))
105 tpapp 1
106 tpapp 6 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
111     (with-context (context pointer)
112     (,(prepend-intern "cairo_" name) pointer ,@args))
113     (sync context)))
114 tpapp 6
115 tpapp 1 (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 tpapp 13 `(defun ,name (,@args &optional (context *context*))
119     (with-context (context ,pointer)
120     ,@body)))
121 tpapp 1
122 tpapp 11 (defmacro define-many-with-default-context (&body args)
123 tpapp 1 "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 tpapp 6 (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 tpapp 1
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 tpapp 6 (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 tpapp 1
151     ;;;;
152     ;;;; simple functions using context
153     ;;;;
154    
155     (define-many-with-default-context
156 tpapp 11 (save)
157     (restore)
158 tpapp 1 (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 tpapp 6 (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 tpapp 15 ;;;; get-target
176    
177     (defun get-target (context)
178     "Obtain the target surface of a given context. Width and height
179     will be nil, as cairo can't provide that in general."
180     (new-surface-with-check (cairo_get_target (slot-value context 'pointer))
181     nil nil))
182    
183 tpapp 10 ;;;;
184 tpapp 11 ;;;; set colors using the cl-colors library
185 tpapp 10 ;;;;
186 tpapp 11
187 tpapp 10 (defgeneric set-source-color (color &optional context))
188    
189 tpapp 13 (defmethod set-source-color ((color rgb) &optional (context *context*))
190 tpapp 11 (with-slots (red green blue) color
191     (set-source-rgb red green blue context)))
192 tpapp 10
193 tpapp 13 (defmethod set-source-color ((color rgba) &optional (context *context*))
194 tpapp 11 (with-slots (red green blue alpha) color
195 tpapp 15 (set-source-rgba red green blue alpha context)))
196 tpapp 10
197 tpapp 13 (defmethod set-source-color ((color hsv) &optional (context *context*))
198 tpapp 11 (with-slots (red green blue) (hsv->rgb color)
199     (set-source-rgb red green blue context)))
200    
201    
202 tpapp 1 ;;;;
203     ;;;; functions that get/set a property without any conversion
204     ;;;;
205    
206     (define-get-set line-width)
207     (define-get-set miter-limit)
208     (define-get-set tolerance)
209    
210     ;;;;
211     ;;;; functions that get/set a property using a lookup table
212     ;;;;
213    
214     (define-get-set-using-table antialias)
215     (define-get-set-using-table fill-rule)
216     (define-get-set-using-table line-cap)
217     (define-get-set-using-table line-join)
218     (define-get-set-using-table operator)
219    
220     ;; fill-path: it should simply be fill, but it is renamed so it does
221     ;; not clash with cl-user:fill
222     (define-flexible (fill-path pointer)
223 tpapp 6 (cairo_fill pointer)
224     (sync context))
225 tpapp 1
226     (define-flexible (set-dash pointer offset dashes)
227     (let ((num-dashes (length dashes)))
228     (with-foreign-object (dashes-pointer :double num-dashes)
229     (copy-double-vector-to-pointer (coerce dashes 'vector) dashes-pointer)
230     (cairo_set_dash pointer dashes-pointer num-dashes offset))))
231    
232     (define-flexible (get-dash pointer)
233     "Return two values: dashes as a vector and the offset."
234     (let ((num-dashes (cairo_get_dash_count pointer)))
235     (with-foreign-objects ((dashes-pointer :double num-dashes)
236     (offset-pointer :double))
237     (cairo_get_dash pointer dashes-pointer offset-pointer)
238     (values (copy-pointer-to-double-vector num-dashes dashes-pointer)
239     (mem-ref offset-pointer :double)))))
240    
241     (defmacro define-get-extents (name)
242     "Define functions that query two coordinate pairs."
243     `(define-flexible (,name pointer)
244     (with-foreign-objects ((x1 :double) (y1 :double)
245     (x2 :double) (y2 :double))
246     (,(prepend-intern "cairo_" name) pointer x1 y1 x2 y2)
247     (values (mem-ref x1 :double) (mem-ref y1 :double)
248     (mem-ref x2 :double) (mem-ref y2 :double)))))
249    
250     (define-get-extents clip-extents)
251     (define-get-extents fill-extents)
252    
253     (define-flexible (in-fill pointer x y)
254     (not (zerop (cairo_in_fill pointer x y))))
255    
256     (define-flexible (in-stroke pointer x y)
257     (not (zerop (cairo_in_stroke pointer x y))))
258 tpapp 13
259     ;;;;
260     ;;;; convenience functions for creating contexts directly
261     ;;;;
262    
263     (define-create-context ps)
264     (define-create-context pdf)
265     (define-create-context svg)

  ViewVC Help
Powered by ViewVC 1.1.5