1 ;; Common Lisp bindings for GTK+ v1.2.x
2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
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.
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.
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
18 ;; $Id: gdk.lisp,v 1.2 2000/08/23 17:32:30 espen Exp $
26 ; (defmethod initialize-instance ((event event) &rest initargs &key)
27 ; (declare (ignore initargs))
31 (defun find-event-class (event-type)
34 (:expose 'expose-event)
35 (:delete 'delete-event))))
37 (deftype-method alien-copier event (type-spec)
38 (declare (ignore type-spec))
41 (deftype-method alien-deallocator event (type-spec)
42 (declare (ignore type-spec))
45 (deftype-method translate-from-alien
46 event (type-spec location &optional (alloc :reference))
47 `(let ((location ,location))
48 (unless (null-pointer-p location)
51 (funcall (get-reader-function 'event-type) location 0))))
53 (:copy '(ensure-alien-instance event-class location))
54 (:static '(ensure-alien-instance event-class location :static t))
55 (:reference '(ensure-alien-instance
56 event-class (%event-copy location))))))))
59 (define-foreign event-poll-fd () int)
61 (define-foreign ("gdk_events_pending" events-pending-p) () boolean)
63 (define-foreign event-get () event)
65 (define-foreign event-peek () event)
67 (define-foreign event-get-graphics-expose () event
70 (define-foreign event-put () event
73 (define-foreign %event-copy (event &optional size) pointer
74 (event (or event pointer)))
76 (define-foreign %event-free () nil
77 (event (or event pointer)))
79 (define-foreign event-get-time () (unsigned 32)
82 ;(define-foreign event-handler-set () ...)
84 (define-foreign set-show-events () nil
85 (show-events boolean))
89 (define-foreign set-use-xshm () nil
92 (define-foreign get-show-events () boolean)
94 (define-foreign get-use-xshm () boolean)
96 (define-foreign get-display () string)
98 ; (define-foreign time-get () (unsigned 32))
100 ; (define-foreign timer-get () (unsigned 32))
102 ; (define-foreign timer-set () nil
103 ; (milliseconds (unsigned 32)))
105 ; (define-foreign timer-enable () nil)
107 ; (define-foreign timer-disable () nil)
111 (define-foreign pointer-grab () int
113 (owner-events boolean)
114 (event-mask event-mask)
115 (confine-to (or null window))
116 (cursor (or null cursor))
117 (time (unsigned 32)))
119 (define-foreign pointer-ungrab () nil
120 (time (unsigned 32)))
122 (define-foreign keyboard-grab () int
124 (owner-events boolean)
125 (time (unsigned 32)))
127 (define-foreign keyboard-ungrab () nil
128 (time (unsigned 32)))
130 (define-foreign ("gdk_pointer_is_grabbed" pointer-is-grabbed-p) () boolean)
132 (define-foreign screen-width () int)
133 (define-foreign screen-height () int)
135 (define-foreign screen-width-mm () int)
136 (define-foreign screen-height-mm () int)
138 (define-foreign flush () nil)
139 (define-foreign beep () nil)
141 (define-foreign key-repeat-disable () nil)
142 (define-foreign key-repeat-restore () nil)
148 (define-foreign visual-get-best-depth () int)
150 (define-foreign visual-get-best-type () visual-type)
152 (define-foreign visual-get-system () visual)
156 ("gdk_visual_get_best" %visual-get-best-with-nothing) () visual)
158 (define-foreign %visual-get-best-with-depth () visual
161 (define-foreign %visual-get-best-with-type () visual
164 (define-foreign %visual-get-best-with-both () visual
168 (defun visual-get-best (&key depth type)
170 ((and depth type) (%visual-get-best-with-both depth type))
171 (depth (%visual-get-best-with-depth depth))
172 (type (%visual-get-best-with-type type))
173 (t (%visual-get-best-with-nothing))))
175 ;(define-foreign query-depths ..)
177 ;(define-foreign query-visual-types ..)
179 (define-foreign list-visuals () (double-list visual))
184 ; (define-foreign window-new ... )
186 (define-foreign window-destroy () nil
190 ; (define-foreign window-at-pointer () window
195 (define-foreign window-show () nil
198 (define-foreign window-hide () nil
201 (define-foreign window-withdraw () nil
204 (define-foreign window-move () nil
209 (define-foreign window-resize () nil
214 (define-foreign window-move-resize () nil
221 (define-foreign window-reparent () nil
227 (define-foreign window-clear () nil
231 '(window-clear-area-no-e window-clear-area-e))
233 (define-foreign ("gdk_window_clear_area" window-clear-area-no-e) () nil
235 (x int) (y int) (width int) (height int))
237 (define-foreign window-clear-area-e () nil
239 (x int) (y int) (width int) (height int))
241 (defun window-clear-area (window x y width height &optional expose)
243 (window-clear-area-e window x y width height)
244 (window-clear-area-no-e window x y width height)))
246 ; (define-foreign window-copy-area () nil
251 ; (source-window window)
257 (define-foreign window-raise () nil
260 (define-foreign window-lower () nil
263 ; (define-foreign window-set-user-data () nil
265 (define-foreign window-set-override-redirect () nil
267 (override-redirect boolean))
269 ; (define-foreign window-add-filter () nil
271 ; (define-foreign window-remove-filter () nil
273 (define-foreign window-shape-combine-mask () nil
279 (define-foreign window-set-child-shapes () nil
282 (define-foreign window-merge-child-shapes () nil
285 (define-foreign ("gdk_window_is_visible" window-is-visible-p) () boolean
288 (define-foreign ("gdk_window_is_viewable" window-is-viewable-p) () boolean
291 (define-foreign window-set-static-gravities () boolean
293 (use-static boolean))
295 ; (define-foreign add-client-message-filter ...
300 (define-foreign drag-context-new () drag-context)
302 (define-foreign drag-context-ref () nil
303 (context drag-context))
305 (define-foreign drag-context-unref () nil
306 (context drag-context))
310 (define-foreign drag-status () nil
311 (context drag-context)
313 (time (unsigned 32)))
318 (define-foreign window-set-cursor () nil
322 (define-foreign window-get-pointer () window
326 (mask modifier-type :out))
328 (define-foreign get-root-window () window)
334 (define-foreign rgb-init () nil)
341 (deftype-method alien-ref cursor (type-spec)
342 (declare (ignore type-spec))
345 (deftype-method alien-unref cursor (type-spec)
346 (declare (ignore type-spec))
350 (define-foreign cursor-new () cursor
351 (cursor-type cursor-type))
353 (define-foreign cursor-new-from-pixmap () cursor
360 (define-foreign %cursor-ref () pointer
361 (cursor (or cursor pointer)))
363 (define-foreign %cursor-unref () nil
364 (cursor (or cursor pointer)))
370 ;; See the class definition for an explanation of this
371 (deftype-method alien-ref bitmap (type-spec)
372 (declare (ignore type-spec))
375 (deftype-method alien-unref bitmap (type-spec)
376 (declare (ignore type-spec))
379 (define-foreign %drawable-ref () pointer
380 (object (or bitmap pointer)))
382 (define-foreign %drawable-unref () nil
383 (object (or bitmap pointer)))
386 (define-foreign pixmap-new (width height depth &key window) pixmap
390 (window (or null window)))
392 (define-foreign %pixmap-colormap-create-from-xpm () pixmap
393 (window (or null window))
394 (colormap (or null colormap))
396 (color (or null color))
399 (define-foreign pixmap-colormap-create-from-xpm-d () pixmap
400 (window (or null window))
401 (colormap (or null colormap))
403 (color (or null color))
406 (defun pixmap-create (source &key color window colormap)
408 (if (not (or window colormap))
411 (multiple-value-bind (pixmap mask)
413 ((or string pathname)
414 (%pixmap-colormap-create-from-xpm
415 window colormap color (namestring (truename source))))
417 ; (with-array (data :initial-contents source :free-contents t)
418 ; (pixmap-colormap-create-from-xpm-d window colormap color data)))
420 (unreference-instance pixmap)
421 (unreference-instance mask)
422 (values pixmap mask))))
428 (defun %scale-value (value)
431 (float (truncate (* value 65535)))))
433 (defmethod initialize-instance ((color color) &rest initargs
434 &key (colors #(0 0 0)) red green blue)
435 (declare (ignore initargs))
437 (with-slots ((%red red) (%green green) (%blue blue)) color
439 %red (%scale-value (or red (svref colors 0)))
440 %green (%scale-value (or green (svref colors 1)))
441 %blue (%scale-value (or blue (svref colors 2))))))
444 (defun ensure-color (color)
448 (vector (make-instance 'color :colors color))))
454 (define-foreign font-load () font
457 (defun ensure-font (font)
461 (string (font-load font))))
463 (define-foreign fontset-load () font
464 (fontset-name string))
466 (define-foreign font-ref () font
469 (define-foreign font-unref () nil
472 (defun font-maybe-unref (font1 font2)
473 (unless (eq font1 font2)
476 (define-foreign font-id () int
479 (define-foreign ("gdk_font_equal" font-equalp) () boolean
483 (define-foreign string-width () int
487 (define-foreign text-width
488 (font text &aux (length (length text))) int
493 ; (define-foreign ("gdk_text_width_wc" text-width-wc)
494 ; (font text &aux (length (length text))) int
499 (define-foreign char-width () int
503 ; (define-foreign ("gdk_char_width_wc" char-width-wc) () int
508 (define-foreign string-measure () int
512 (define-foreign text-measure
513 (font text &aux (length (length text))) int
518 (define-foreign char-measure () int
522 (define-foreign string-height () int
526 (define-foreign text-height
527 (font text &aux (length (length text))) int
532 (define-foreign char-height () int
537 ;;; Drawing functions
539 (define-foreign draw-rectangle () nil
540 (drawable (or window pixmap bitmap))
541 (gc gc) (filled boolean)
542 (x int) (y int) (width int) (height int))
547 (define-foreign keyval-name () string
548 (keyval unsigned-int))
550 (define-foreign keyval-from-name () unsigned-int
553 (define-foreign keyval-to-upper () unsigned-int
554 (keyval unsigned-int))
556 (define-foreign keyval-to-lower ()unsigned-int
557 (keyval unsigned-int))
559 (define-foreign ("gdk_keyval_is_upper" keyval-is-upper-p) () boolean
560 (keyval unsigned-int))
562 (define-foreign ("gdk_keyval_is_lower" keyval-is-lower-p) () boolean
563 (keyval unsigned-int))