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

Contents of /transformations.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5