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

Contents of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6 - (hide annotations)
Thu Jun 21 09:07:42 2007 UTC (6 years, 10 months ago) by tpapp
File size: 6416 byte(s)
added svg and xlib support
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     (defclass context () ((pointer :initform nil)))
26    
27     (export
28     (defun create-context (surface)
29     (with-surface (surface pointer)
30     (let ((context (make-instance 'context)))
31     (setf (slot-value context 'pointer) (cairo_create pointer))
32     ;; !!! error checking
33     context))))
34    
35     (defmethod destroy ((object context))
36     (with-slots (pointer) object
37     (when pointer
38     (cairo_destroy pointer)
39     (setf pointer nil))))
40    
41 tpapp 6 (defmethod sync ((object context))
42     ;; most contexts don't need syncing
43     )
44    
45 tpapp 1 ;;;;
46     ;;;; default context and convenience macros
47     ;;;;
48    
49     (export (defvar *context* nil "default cairo context"))
50    
51     (defmacro with-context ((context pointer) &body body)
52     "Execute body with pointer pointing to context, and check status."
53     (let ((status (gensym))
54     (pointer-name pointer))
55     `(with-slots ((,pointer-name pointer)) ,context
56     (if ,pointer-name
57     (multiple-value-prog1 (progn ,@body)
58     (let ((,status
59     (lookup-cairo-enum (cairo_status ,pointer-name) table-status)))
60     (unless (eq ,status 'success)
61     (warn "function returned with status ~a." ,status))))
62     (warn "context is not alive")))))
63    
64     (defmacro define-with-default-context (name &rest args)
65     "Define cairo function with *context* as its first argument and
66     args as the rest, automatically mapping name to the appropriate
67     cairo function."
68     `(export
69     (defun ,name (,@args &optional (context *context*))
70     (with-context (context pointer)
71     (,(prepend-intern "cairo_" name) pointer ,@args)))))
72    
73 tpapp 6 (defmacro define-with-default-context-sync (name &rest args)
74     "Define cairo function with *context* as its first argument and
75     args as the rest, automatically mapping name to the appropriate
76     cairo function. sync will be called after the operation."
77     `(export
78     (defun ,name (,@args &optional (context *context*))
79     (with-context (context pointer)
80     (,(prepend-intern "cairo_" name) pointer ,@args))
81     (sync context))))
82    
83 tpapp 1 (defmacro define-flexible ((name pointer &rest args) &body body)
84     "Like define-with-default context, but with arbitrary body,
85     pointer will point to the context."
86     `(export
87     (defun ,name (,@args &optional (context *context*))
88     (with-context (context ,pointer)
89     ,@body))))
90    
91     (defmacro define-many-with-default-context (&rest args)
92     "Apply define-with-default context to a list. Each item is
93     itself a list, first element gives the function name, the rest
94     the arguments."
95     `(progn
96     ,@(loop for arglist in args
97     collect `(define-with-default-context ,(car arglist) ,@(cdr arglist)))))
98    
99     (defmacro define-get-set (property)
100     "Define set-property and get-property functions."
101     `(progn
102 tpapp 6 (define-with-default-context ,(prepend-intern "get-" property :replace-dash nil))
103     (define-with-default-context ,(prepend-intern "set-" property :replace-dash nil)
104     ,property)))
105 tpapp 1
106     (defmacro define-get-set-using-table (property)
107     "Define set-property and get-property functions, where property
108     is looked up in table-property for conversion into Cairo's enum
109     constants."
110     `(progn
111 tpapp 6 (define-flexible (,(prepend-intern "get-" property :replace-dash nil) pointer)
112     (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer)
113     ,(prepend-intern "table-" property :replace-dash nil)))
114     (define-flexible (,(prepend-intern "set-" property :replace-dash nil)
115     pointer ,property)
116     (,(prepend-intern "cairo_set_" property) pointer
117     (lookup-enum ,property ,(prepend-intern "table-"
118     property :replace-dash nil))))))
119 tpapp 1
120     ;;;;
121     ;;;; simple functions using context
122     ;;;;
123    
124     (define-with-default-context save)
125     (define-many-with-default-context
126     (save)
127     (restore)
128     (push-group)
129     (pop-group)
130     (pop-group-to-source)
131     (set-source-rgb red green blue)
132     (set-source-rgba red green blue alpha)
133     (clip)
134     (clip-preserve)
135     (reset-clip)
136     (copy-page)
137     (show-page))
138    
139 tpapp 6 (define-with-default-context-sync fill-preserve)
140     (define-with-default-context-sync paint)
141     (define-with-default-context-sync paint-with-alpha alpha)
142     (define-with-default-context-sync stroke)
143     (define-with-default-context-sync stroke-preserve)
144    
145 tpapp 1 ;;;;
146     ;;;; functions that get/set a property without any conversion
147     ;;;;
148    
149     (define-get-set line-width)
150     (define-get-set miter-limit)
151     (define-get-set tolerance)
152    
153     ;;;;
154     ;;;; functions that get/set a property using a lookup table
155     ;;;;
156    
157     (define-get-set-using-table antialias)
158     (define-get-set-using-table fill-rule)
159     (define-get-set-using-table line-cap)
160     (define-get-set-using-table line-join)
161     (define-get-set-using-table operator)
162    
163     ;; fill-path: it should simply be fill, but it is renamed so it does
164     ;; not clash with cl-user:fill
165     (define-flexible (fill-path pointer)
166 tpapp 6 (cairo_fill pointer)
167     (sync context))
168 tpapp 1
169     (define-flexible (set-dash pointer offset dashes)
170     (let ((num-dashes (length dashes)))
171     (with-foreign-object (dashes-pointer :double num-dashes)
172     (copy-double-vector-to-pointer (coerce dashes 'vector) dashes-pointer)
173     (cairo_set_dash pointer dashes-pointer num-dashes offset))))
174    
175     (define-flexible (get-dash pointer)
176     "Return two values: dashes as a vector and the offset."
177     (let ((num-dashes (cairo_get_dash_count pointer)))
178     (with-foreign-objects ((dashes-pointer :double num-dashes)
179     (offset-pointer :double))
180     (cairo_get_dash pointer dashes-pointer offset-pointer)
181     (values (copy-pointer-to-double-vector num-dashes dashes-pointer)
182     (mem-ref offset-pointer :double)))))
183    
184     (defmacro define-get-extents (name)
185     "Define functions that query two coordinate pairs."
186     `(define-flexible (,name pointer)
187     (with-foreign-objects ((x1 :double) (y1 :double)
188     (x2 :double) (y2 :double))
189     (,(prepend-intern "cairo_" name) pointer x1 y1 x2 y2)
190     (values (mem-ref x1 :double) (mem-ref y1 :double)
191     (mem-ref x2 :double) (mem-ref y2 :double)))))
192    
193     (define-get-extents clip-extents)
194     (define-get-extents fill-extents)
195    
196     (define-flexible (in-fill pointer x y)
197     (not (zerop (cairo_in_fill pointer x y))))
198    
199     (define-flexible (in-stroke pointer x y)
200     (not (zerop (cairo_in_stroke pointer x y))))

  ViewVC Help
Powered by ViewVC 1.1.5