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

Contents of /transformations.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 11 - (show annotations)
Mon Aug 13 14:30:44 2007 UTC (6 years, 8 months ago) by tpapp
File size: 5443 byte(s)
minor bugfixes, complete reworking of x11 support, support for cl-colors
1 (in-package :cl-cairo2)
2
3 ;;;; Notes
4 ;;;;
5 ;;;; cairo-matrix-init is not defined, as we have a structure in lisp
6 ;;;; with an appropriate constructor
7 ;;;;
8 ;;;; cairo_identity_matrix is reset-matrix
9 ;;;;
10 ;;;; functions that manipulate transformation matrices have
11 ;;;; trans-matrix instead of matrix in their name
12 ;;;;
13 ;;;; cairo_matrix_transform_distance and cairo_matrix_transform_point
14 ;;;; are simply transform-distance and transform-point
15
16 ;;;;
17 ;;;; simple functions
18 ;;;;
19
20 (define-many-with-default-context
21 (translate tx ty)
22 (scale sx sy)
23 (rotate angle))
24
25 (define-flexible (reset-matrix pointer)
26 (cairo_identity_matrix pointer))
27
28
29 ;;;;
30 ;;;; transition matrix structure and helper functions/macros
31 ;;;;
32
33 (defstruct trans-matrix xx yx xy yy x0 y0)
34
35 (defun trans-matrix-copy-in (pointer matrix)
36 "Copy matrix to a memory location."
37 (with-foreign-slots ((xx yx xy yy x0 y0) pointer cairo_matrix_t)
38 (setf xx (trans-matrix-xx matrix)
39 yx (trans-matrix-yx matrix)
40 xy (trans-matrix-xy matrix)
41 yy (trans-matrix-yy matrix)
42 x0 (trans-matrix-x0 matrix)
43 y0 (trans-matrix-y0 matrix))))
44
45 (defun trans-matrix-copy-out (pointer matrix)
46 "Copy contents of a memory location to a transition matrix."
47 (with-foreign-slots ((xx yx xy yy x0 y0) pointer cairo_matrix_t)
48 (setf (trans-matrix-xx matrix) xx
49 (trans-matrix-yx matrix) yx
50 (trans-matrix-xy matrix) xy
51 (trans-matrix-yy matrix) yy
52 (trans-matrix-x0 matrix) x0
53 (trans-matrix-y0 matrix) y0)))
54
55 (defmacro with-trans-matrix-in (matrix pointer &body body)
56 "Execute body with pointer pointing to a memory location with matrix."
57 `(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
58 (trans-matrix-copy-in ,pointer ,matrix)
59 ,@body))
60
61 (defmacro with-trans-matrix-out (pointer &body body)
62 "Execute body with pointer pointing to an uninitialized location,
63 then copy this to matrix and return the matrix."
64 (let ((matrix-name (gensym)))
65 `(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
66 (let ((,matrix-name (make-trans-matrix)))
67 ,@body
68 (trans-matrix-copy-out ,pointer ,matrix-name)
69 ,matrix-name))))
70
71 (defmacro with-trans-matrix-in-out (matrix pointer &body body)
72 (let ((matrix-name (gensym)))
73 `(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
74 (let ((,matrix-name (make-trans-matrix)))
75 (trans-matrix-copy-in ,pointer ,matrix)
76 ,@body
77 (trans-matrix-copy-out ,pointer ,matrix-name)
78 ,matrix-name))))
79
80 (defmacro with-x-y (&body body)
81 "Creates temporary variables on the stack with pointers xp and yp,
82 and copies x and y in/out before/after (respectively) the
83 execution of body."
84 `(with-foreign-objects ((xp :double) (yp :double))
85 (setf (mem-ref xp :double) (coerce x 'double-float)
86 (mem-ref yp :double) (coerce y 'double-float))
87 ,@body
88 (values (mem-ref xp :double) (mem-ref yp :double))))
89
90 (defmacro define-with-x-y (name)
91 "Defines a function that is called with context, x and y, and
92 returns the latter two."
93 `(define-flexible (,name pointer x y)
94 (with-x-y
95 (,(prepend-intern "cairo_" name) pointer xp yp))))
96
97 ;;;;
98 ;;;; transformation and conversion functions
99 ;;;;
100
101 (define-flexible (transform pointer matrix)
102 (with-trans-matrix-in matrix matrix-pointer
103 (cairo_transform pointer matrix-pointer)))
104
105 (define-flexible (set-trans-matrix pointer matrix)
106 (with-trans-matrix-in matrix matrix-pointer
107 (cairo_set_matrix pointer matrix-pointer)))
108
109 (define-flexible (get-trans-matrix pointer)
110 (with-trans-matrix-out matrix-pointer
111 (cairo_set_matrix pointer matrix-pointer)))
112
113 (define-with-x-y user-to-device)
114 (define-with-x-y user-to-device-distance)
115 (define-with-x-y device-to-user)
116 (define-with-x-y device-to-user-distance)
117
118 ;;;;
119 ;;;; transformations
120 ;;;;
121
122 (defmacro define-matrix-init (name &rest args)
123 "Define a matrix initializer function with args, which returns the
124 new matrix."
125 `(export
126 (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args
127 (with-trans-matrix-out matrix-pointer
128 (,(prepend-intern "cairo_matrix_init_" name)
129 matrix-pointer
130 ,@args)))))
131
132 (define-matrix-init identity)
133 (define-matrix-init translate tx ty)
134 (define-matrix-init scale sx sy)
135 (define-matrix-init rotate radians)
136
137 (defmacro define-matrix-transformation (name &rest args)
138 "Define a matrix transformation function with matrix and args,
139 which returns the new matrix."
140 `(export
141 (defun ,(prepend-intern "trans-matrix-" name :replace-dash nil) (matrix ,@args)
142 (with-trans-matrix-in-out matrix matrix-pointer
143 (,(prepend-intern "cairo_matrix_" name)
144 matrix-pointer
145 ,@args)))))
146
147 (define-matrix-transformation translate tx ty)
148 (define-matrix-transformation scale sx sy)
149 (define-matrix-transformation rotate radians)
150 (define-matrix-transformation invert)
151
152 (export
153 (defun trans-matrix-multiply (a b)
154 (with-trans-matrix-in a a-pointer
155 (with-trans-matrix-in b b-pointer
156 (with-trans-matrix-out result-pointer
157 (cairo_matrix_multiply result-pointer
158 a-pointer
159 b-pointer))))))
160
161 (export
162 (defun transform-distance (matrix x y)
163 (with-trans-matrix-in matrix matrix-pointer
164 (with-x-y
165 (cairo_matrix_transform_distance matrix-pointer xp yp)))))
166
167 (export
168 (defun transform-point (matrix x y)
169 (with-trans-matrix-in matrix matrix-pointer
170 (with-x-y
171 (cairo_matrix_transform_point matrix-pointer xp yp)))))

  ViewVC Help
Powered by ViewVC 1.1.5