0d07716f |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
2 | ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no> |
3 | ;; |
4 | ;; This library is free software; you can redistribute it and/or |
5 | ;; modify it under the terms of the GNU Lesser General Public |
6 | ;; License as published by the Free Software Foundation; either |
7 | ;; version 2 of the License, or (at your option) any later version. |
8 | ;; |
9 | ;; This library is distributed in the hope that it will be useful, |
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;; Lesser General Public License for more details. |
13 | ;; |
14 | ;; You should have received a copy of the GNU Lesser General Public |
15 | ;; License along with this library; if not, write to the Free Software |
16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
17 | |
ecb4e7dc |
18 | ;; $Id: gtkwidget.lisp,v 1.1.1.1 2000/08/14 16:45:02 espen Exp $ |
0d07716f |
19 | |
20 | (in-package "GTK") |
21 | |
22 | |
23 | (eval-when (:compile-toplevel :load-toplevel :execute) |
24 | (defclass widget (object) |
25 | ((child-slots |
26 | :allocation :instance |
27 | :accessor widget-child-slots |
28 | :type container-child) |
29 | (name |
30 | :allocation :arg |
31 | :accessor widget-name |
32 | :initarg :name |
33 | :type string) |
34 | (parent |
35 | :allocation :arg |
36 | :accessor widget-parent |
37 | ; :initarg :parent |
38 | :type container) |
39 | (x |
40 | :allocation :arg |
41 | :accessor widget-x-position |
42 | :initarg :x |
43 | :type int) |
44 | (y |
45 | :allocation :arg |
46 | :accessor widget-y-position |
47 | :initarg :y |
48 | :type int) |
49 | (width |
50 | :allocation :arg |
51 | :accessor widget-width |
52 | :initarg :width |
53 | :type int) |
54 | (height |
55 | :allocation :arg |
56 | :accessor widget-height |
57 | :initarg :height |
58 | :type int) |
59 | (visible |
60 | :allocation :arg |
61 | :accessor widget-visible-p |
62 | :initarg :visible |
63 | :type boolean) |
64 | (sensitive |
65 | :allocation :arg |
66 | :accessor widget-sensitive-p |
67 | :initarg :sensitive |
68 | :type boolean) |
69 | (app-paintable |
70 | :allocation :arg |
71 | :reader widget-app-paintable-p |
72 | ; :access :read-only |
73 | :type boolean) |
74 | (can-focus |
75 | :allocation :arg |
76 | :accessor widget-can-focus-p |
77 | :initarg :can-focus |
78 | :type boolean) |
79 | (has-focus |
80 | :allocation :arg |
81 | :accessor widget-has-focus-p |
82 | :initarg :has-focus |
83 | :type boolean) |
84 | (can-default |
85 | :allocation :arg |
86 | :accessor widget-can-default-p |
87 | :initarg :can-default |
88 | :type boolean) |
89 | (has-default |
90 | :allocation :arg |
91 | :accessor widget-has-default-p |
92 | :initarg :has-default |
93 | :type boolean) |
94 | (receives-default |
95 | :allocation :arg |
96 | :accessor widget-receives-default-p |
97 | :initarg :receives-default |
98 | :type boolean) |
99 | (composite-child |
100 | :allocation :arg |
101 | :accessor widget-composite-child-p |
102 | :initarg :composite-child |
103 | :type boolean) |
104 | ; (style |
105 | ; :allocation :arg |
106 | ; :accessor widget-style |
107 | ; :initarg :style |
108 | ; :type style) |
109 | (events |
110 | :allocation :arg |
111 | :accessor widget-events |
112 | :initarg :events |
113 | :type gdk:event-mask) |
114 | (extension-events |
115 | :allocation :arg |
116 | :accessor widget-extension-events |
117 | :initarg :extpension-events |
118 | :type gdk:event-mask) |
119 | (state |
120 | :allocation :virtual |
121 | :location ("gtk_widget_get_state" "gtk_widget_set_state") |
122 | :accessor widget-state |
123 | :initarg :state |
124 | :type state-type) |
125 | (window |
126 | :allocation :virtual |
127 | :location "gtk_widget_get_window" |
128 | :reader widget-window |
129 | :type gdk:window) |
130 | (colormap |
131 | :allocation :virtual |
132 | :location "gtk_widget_get_colormap" |
133 | :reader widget-colormap |
134 | :type gdk:colormap) |
135 | (visual |
136 | :allocation :virtual |
137 | :location "gtk_widget_get_visual" |
138 | :reader widget-visual |
139 | :type gdk:visual)) |
140 | (:metaclass object-class) |
141 | (:alien-name "GtkWidget"))) |
142 | |
143 | |
144 | (defmethod initialize-instance ((widget widget) &rest initargs &key parent) |
145 | (declare (ignore initargs)) |
146 | (cond |
147 | ((consp parent) |
148 | (with-slots ((container parent) child-slots) widget |
149 | (setf |
150 | container (car parent) |
151 | child-slots |
152 | (apply |
153 | #'make-instance |
154 | (slot-value (class-of container) 'child-class) |
155 | :parent container :child widget (cdr parent))))) |
156 | (parent |
157 | (setf (slot-value widget 'parent) parent))) |
158 | (call-next-method)) |
159 | |
160 | |
161 | (defmethod slot-unbound ((class object-class) (object widget) slot) |
162 | (cond |
163 | ((and (eq slot 'child-slots) (slot-value object 'parent)) |
164 | (with-slots (parent child-slots) object |
165 | (setf |
166 | child-slots |
167 | (make-instance |
168 | (slot-value (class-of parent) 'child-class) |
169 | :parent parent :child object)))) |
170 | (t (call-next-method)))) |
171 | |
172 | |
173 | (defun child-slot-value (widget slot) |
174 | (slot-value (widget-child-slots widget) slot)) |
175 | |
176 | (defun (setf child-slot-value) (value widget slot) |
177 | (setf (slot-value (widget-child-slots widget) slot) value)) |
178 | |
179 | (defmacro with-child-slots (slots widget &body body) |
180 | `(with-slots ,slots (widget-child-slots ,widget) |
181 | ,@body)) |
182 | |
183 | (defmacro widget-destroyed (place) |
184 | `(setf ,place nil)) |
185 | |
186 | (define-foreign widget-destroy () nil |
187 | (widget widget)) |
188 | |
189 | (define-foreign widget-unparent () nil |
190 | (widget widget)) |
191 | |
192 | (define-foreign widget-show () nil |
193 | (widget widget)) |
194 | |
195 | (define-foreign widget-show-now () nil |
196 | (widget widget)) |
197 | |
198 | (define-foreign widget-hide () nil |
199 | (widget widget)) |
200 | |
201 | (define-foreign widget-show-all () nil |
202 | (widget widget)) |
203 | |
204 | (define-foreign widget-hide-all () nil |
205 | (widget widget)) |
206 | |
207 | (define-foreign widget-map () nil |
208 | (widget widget)) |
209 | |
210 | (define-foreign widget-unmap () nil |
211 | (widget widget)) |
212 | |
213 | (define-foreign widget-realize () nil |
214 | (widget widget)) |
215 | |
216 | (define-foreign widget-unrealize () nil |
217 | (widget widget)) |
218 | |
219 | (define-foreign widget-add-accelerator |
220 | (widget signal accel-group key modifiers flags) nil |
221 | (widget widget) |
222 | ((name-to-string signal) string) |
223 | (accel-group accel-group) |
224 | ((gdk:keyval-from-name key) unsigned-int) |
225 | (modifiers gdk:modifier-type) |
226 | (flags accel-flags)) |
227 | |
228 | (define-foreign widget-remove-accelerator |
229 | (widget accel-group key modifiers) nil |
230 | (widget widget) |
231 | (accel-group accel-group) |
232 | ((gdk:keyval-from-name key) unsigned-int) |
233 | (modifiers gdk:modifier-type)) |
234 | |
235 | (define-foreign widget-accelerator-signal |
236 | (widget accel-group key modifiers) unsigned-int |
237 | (widget widget) |
238 | (accel-group accel-group) |
239 | ((gdk:keyval-from-name key) unsigned-int) |
240 | (modifiers gdk:modifier-type)) |
241 | |
242 | (define-foreign widget-lock-accelerators () nil |
243 | (widget widget)) |
244 | |
245 | (define-foreign widget-unlock-accelerators () nil |
246 | (widget widget)) |
247 | |
248 | (define-foreign |
249 | ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean |
250 | (widget widget)) |
251 | |
252 | (define-foreign widget-event () int |
253 | (widget widget) |
254 | (event gdk:event)) |
255 | |
256 | (define-foreign widget-activate () boolean |
257 | (widget widget)) |
258 | |
259 | (define-foreign widget-set-scroll-adjustments () boolean |
260 | (widget widget) |
261 | (hadjustment adjustment) |
262 | (vadjustment adjustment)) |
263 | |
264 | (define-foreign widget-reparent () nil |
265 | (widget widget) |
266 | (new-parent widget)) |
267 | |
268 | (define-foreign widget-popup () nil |
269 | (widget widget) |
270 | (x int) |
271 | (y int)) |
272 | |
273 | (define-foreign widget-grab-focus () nil |
274 | (widget widget)) |
275 | |
276 | (define-foreign widget-grab-default () nil |
277 | (widget widget)) |
278 | |
279 | ;; cl-gtk.c |
280 | (define-foreign widget-allocation () nil |
281 | (widget widget) |
282 | (width int :out) |
283 | (height int :out)) |
284 | |
285 | |
286 | (define-foreign widget-set-uposition (widget &key (x t) (y t)) nil |
287 | (widget widget) |
288 | ((case x |
289 | ((t) -2) |
290 | ((nil) -1) |
291 | (otherwise x)) int) |
292 | ((case y |
293 | ((t) -2) |
294 | ((nil) -1) |
295 | (otherwise y)) int)) |
296 | |
297 | (define-foreign widget-add-events () nil |
298 | (widget widget) |
299 | (events gdk:event-mask)) |
300 | |
301 | (define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget |
302 | (widget widget)) |
303 | |
304 | (define-foreign ("gtk_widget_get_ancestor" |
305 | widget-ancestor) (widget type) widget |
306 | (widget widget) |
307 | ((find-type-number type) type-number)) |
308 | |
309 | ; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap |
310 | ; (widget widget)) |
311 | |
312 | ; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual |
313 | ; (widget widget)) |
314 | |
315 | (define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil |
316 | (widget widget) |
317 | (x int :out) |
318 | (y int :out)) |
319 | |
320 | (define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean |
321 | (widget widget) |
322 | (ancestor widget)) |
323 | |
324 | (define-foreign widget-set-rc-style () nil |
325 | (widget widget)) |
326 | |
327 | (define-foreign widget-ensure-style () nil |
328 | (widget widget)) |
329 | |
330 | (define-foreign widget-restore-default-style () nil |
331 | (widget widget)) |
332 | |
333 | (define-foreign widget-reset-rc-styles () nil |
334 | (widget widget)) |
335 | |
336 | (defun (setf widget-cursor) (cursor-type widget) |
337 | (let ((cursor (gdk:cursor-new cursor-type)) |
338 | (window (widget-window widget))) |
339 | (gdk:window-set-cursor window cursor) |
340 | ;(gdk:cursor-destroy cursor) |
341 | )) |
342 | |
343 | ;; Push/pop pairs, to change default values upon a widget's creation. |
344 | ;; This will override the values that got set by the |
345 | ;; widget-set-default-* functions. |
346 | |
347 | (define-foreign widget-push-style () nil |
348 | (style style)) |
349 | |
350 | (define-foreign widget-push-colormap () nil |
351 | (colormap gdk:colormap)) |
352 | |
353 | ; (define-foreign widget-push-visual () nil |
354 | ; (visual gdk:visual)) |
355 | |
356 | (define-foreign widget-push-composite-child () nil) |
357 | |
358 | (define-foreign widget-pop-style () nil) |
359 | |
360 | (define-foreign widget-pop-colormap () nil) |
361 | |
362 | ;(define-foreign widget-pop-visual () nil) |
363 | |
364 | (define-foreign widget-pop-composite-child () nil) |
365 | |
366 | |
367 | ;; Set certain default values to be used at widget creation time. |
368 | |
369 | (define-foreign widget-set-default-style () nil |
370 | (style style)) |
371 | |
372 | (define-foreign widget-set-default-colormap () nil |
373 | (colormap gdk:colormap)) |
374 | |
375 | ; (define-foreign widget-set-default-visual () nil |
376 | ; (visual gdk:visual)) |
377 | |
378 | (define-foreign widget-get-default-style () style) |
379 | |
380 | (define-foreign widget-get-default-colormap () gdk:colormap) |
381 | |
382 | (define-foreign widget-get-default-visual () gdk:visual) |
383 | |
384 | (define-foreign widget-shape-combine-mask () nil |
385 | (widget widget) |
386 | (shape-mask gdk:bitmap) |
387 | (x-offset int) |
388 | (y-offset int)) |
389 | |
390 | ;; cl-gtk.c |
391 | (define-foreign widget-mapped-p () boolean |
392 | (widget widget)) |
393 | |