560af5c5 |
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 | |
aace61f5 |
18 | ;; $Id: gtkwidget.lisp,v 1.2 2000-08-16 22:16:44 espen Exp $ |
560af5c5 |
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 | |
aace61f5 |
256 | (define-foreign get-event-widget () widget |
257 | (event gdk:event)) |
258 | |
560af5c5 |
259 | (define-foreign widget-activate () boolean |
260 | (widget widget)) |
261 | |
262 | (define-foreign widget-set-scroll-adjustments () boolean |
263 | (widget widget) |
264 | (hadjustment adjustment) |
265 | (vadjustment adjustment)) |
266 | |
267 | (define-foreign widget-reparent () nil |
268 | (widget widget) |
269 | (new-parent widget)) |
270 | |
271 | (define-foreign widget-popup () nil |
272 | (widget widget) |
273 | (x int) |
274 | (y int)) |
275 | |
276 | (define-foreign widget-grab-focus () nil |
277 | (widget widget)) |
278 | |
279 | (define-foreign widget-grab-default () nil |
280 | (widget widget)) |
281 | |
aace61f5 |
282 | (define-foreign grab-add () nil |
283 | (widget widget)) |
284 | |
285 | (define-foreign grab-get-current () widget) |
286 | |
287 | (define-foreign grab-remove () nil |
288 | (widget widget)) |
289 | |
560af5c5 |
290 | (define-foreign widget-allocation () nil |
291 | (widget widget) |
292 | (width int :out) |
293 | (height int :out)) |
294 | |
295 | |
296 | (define-foreign widget-set-uposition (widget &key (x t) (y t)) nil |
297 | (widget widget) |
298 | ((case x |
299 | ((t) -2) |
300 | ((nil) -1) |
301 | (otherwise x)) int) |
302 | ((case y |
303 | ((t) -2) |
304 | ((nil) -1) |
305 | (otherwise y)) int)) |
306 | |
307 | (define-foreign widget-add-events () nil |
308 | (widget widget) |
309 | (events gdk:event-mask)) |
310 | |
311 | (define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget |
312 | (widget widget)) |
313 | |
314 | (define-foreign ("gtk_widget_get_ancestor" |
315 | widget-ancestor) (widget type) widget |
316 | (widget widget) |
317 | ((find-type-number type) type-number)) |
318 | |
319 | ; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap |
320 | ; (widget widget)) |
321 | |
322 | ; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual |
323 | ; (widget widget)) |
324 | |
325 | (define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil |
326 | (widget widget) |
327 | (x int :out) |
328 | (y int :out)) |
329 | |
330 | (define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean |
331 | (widget widget) |
332 | (ancestor widget)) |
333 | |
334 | (define-foreign widget-set-rc-style () nil |
335 | (widget widget)) |
336 | |
337 | (define-foreign widget-ensure-style () nil |
338 | (widget widget)) |
339 | |
340 | (define-foreign widget-restore-default-style () nil |
341 | (widget widget)) |
342 | |
343 | (define-foreign widget-reset-rc-styles () nil |
344 | (widget widget)) |
345 | |
346 | (defun (setf widget-cursor) (cursor-type widget) |
347 | (let ((cursor (gdk:cursor-new cursor-type)) |
348 | (window (widget-window widget))) |
349 | (gdk:window-set-cursor window cursor) |
350 | ;(gdk:cursor-destroy cursor) |
351 | )) |
352 | |
353 | ;; Push/pop pairs, to change default values upon a widget's creation. |
354 | ;; This will override the values that got set by the |
355 | ;; widget-set-default-* functions. |
356 | |
357 | (define-foreign widget-push-style () nil |
358 | (style style)) |
359 | |
360 | (define-foreign widget-push-colormap () nil |
361 | (colormap gdk:colormap)) |
362 | |
363 | ; (define-foreign widget-push-visual () nil |
364 | ; (visual gdk:visual)) |
365 | |
366 | (define-foreign widget-push-composite-child () nil) |
367 | |
368 | (define-foreign widget-pop-style () nil) |
369 | |
370 | (define-foreign widget-pop-colormap () nil) |
371 | |
372 | ;(define-foreign widget-pop-visual () nil) |
373 | |
374 | (define-foreign widget-pop-composite-child () nil) |
375 | |
376 | |
377 | ;; Set certain default values to be used at widget creation time. |
378 | |
379 | (define-foreign widget-set-default-style () nil |
380 | (style style)) |
381 | |
382 | (define-foreign widget-set-default-colormap () nil |
383 | (colormap gdk:colormap)) |
384 | |
385 | ; (define-foreign widget-set-default-visual () nil |
386 | ; (visual gdk:visual)) |
387 | |
388 | (define-foreign widget-get-default-style () style) |
389 | |
390 | (define-foreign widget-get-default-colormap () gdk:colormap) |
391 | |
392 | (define-foreign widget-get-default-visual () gdk:visual) |
393 | |
394 | (define-foreign widget-shape-combine-mask () nil |
395 | (widget widget) |
396 | (shape-mask gdk:bitmap) |
397 | (x-offset int) |
398 | (y-offset int)) |
399 | |
aace61f5 |
400 | ;; defined in gtkglue.c |
560af5c5 |
401 | (define-foreign widget-mapped-p () boolean |
402 | (widget widget)) |
403 | |