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.5 2000-10-05 17:19:26 espen Exp $
26 ; (defmethod initialize-instance ((event event) &rest initargs &key)
27 ; (declare (ignore initargs))
31 (defun find-event-class (event-type)
34 (:delete 'delete-event)
35 (:destroy 'destroy-event)
36 (:expose 'expose-event)
37 (:motion-notify 'motion-notify-event)
38 (:button-press 'button-press-event)
39 (:2button-press '2-button-press-event)
40 (:3button-press '3-button-press-event)
41 (:button-release 'button-release-event)
42 (:key-press 'key-press-event)
43 (:key-release 'key-release-event)
44 (:enter-notify 'enter-notify-event)
45 (:leave-notify 'leave-notify-event)
46 (:focus-change 'focus-change-event)
47 (:configure 'configure-event)
50 (:property-notify 'property-notify-event)
51 (:selection-clear 'selection-clear-event)
52 (:selection-request 'selection-request-event)
53 (:selection-notify 'selection-notify-event)
54 (:proximity-in 'proximity-in-event)
55 (:proximity-out 'proximity-out-event)
56 (:drag-enter 'drag-enter-event)
57 (:drag-leave 'drag-leave-event)
58 (:drag-motion 'drag-motion-event)
59 (:drag-status 'drag-status-event)
60 (:drop-start 'drop-start-event)
61 (:drop-finished 'drop-finished-event)
62 (:client-event 'client-event-event)
63 (:visibility-notify 'visibility-notify-event)
64 (:no-expose 'no-expose-event)
65 (:scroll 'scroll-event))))
68 (deftype-method alien-copier event (type-spec)
69 (declare (ignore type-spec))
72 (deftype-method alien-deallocator event (type-spec)
73 (declare (ignore type-spec))
76 (deftype-method translate-from-alien
77 event (type-spec location &optional (alloc :reference))
78 `(let ((location ,location))
79 (unless (null-pointer-p location)
82 (funcall (get-reader-function 'event-type) location 0))))
84 (:copy '(ensure-alien-instance event-class location))
85 (:static '(ensure-alien-instance event-class location :static t))
86 (:reference '(ensure-alien-instance
87 event-class (%event-copy location))))))))
90 (define-foreign event-poll-fd () int)
92 (define-foreign ("gdk_events_pending" events-pending-p) () boolean)
94 (define-foreign event-get () event)
96 (define-foreign event-peek () event)
98 (define-foreign event-get-graphics-expose () event
101 (define-foreign event-put () event
104 (define-foreign %event-copy (event &optional size) pointer
105 (event (or event pointer)))
107 (define-foreign %event-free () nil
108 (event (or event pointer)))
110 (define-foreign event-get-time () (unsigned 32)
113 ;(define-foreign event-handler-set () ...)
115 (define-foreign set-show-events () nil
116 (show-events boolean))
120 (define-foreign set-use-xshm () nil
123 (define-foreign get-show-events () boolean)
125 (define-foreign get-use-xshm () boolean)
127 (define-foreign get-display () string)
129 ; (define-foreign time-get () (unsigned 32))
131 ; (define-foreign timer-get () (unsigned 32))
133 ; (define-foreign timer-set () nil
134 ; (milliseconds (unsigned 32)))
136 ; (define-foreign timer-enable () nil)
138 ; (define-foreign timer-disable () nil)
142 (define-foreign pointer-grab () int
144 (owner-events boolean)
145 (event-mask event-mask)
146 (confine-to (or null window))
147 (cursor (or null cursor))
148 (time (unsigned 32)))
150 (define-foreign pointer-ungrab () nil
151 (time (unsigned 32)))
153 (define-foreign keyboard-grab () int
155 (owner-events boolean)
156 (time (unsigned 32)))
158 (define-foreign keyboard-ungrab () nil
159 (time (unsigned 32)))
161 (define-foreign ("gdk_pointer_is_grabbed" pointer-is-grabbed-p) () boolean)
163 (define-foreign screen-width () int)
164 (define-foreign screen-height () int)
166 (define-foreign screen-width-mm () int)
167 (define-foreign screen-height-mm () int)
169 (define-foreign flush () nil)
170 (define-foreign beep () nil)
172 (define-foreign key-repeat-disable () nil)
173 (define-foreign key-repeat-restore () nil)
179 (define-foreign visual-get-best-depth () int)
181 (define-foreign visual-get-best-type () visual-type)
183 (define-foreign visual-get-system () visual)
187 ("gdk_visual_get_best" %visual-get-best-with-nothing) () visual)
189 (define-foreign %visual-get-best-with-depth () visual
192 (define-foreign %visual-get-best-with-type () visual
195 (define-foreign %visual-get-best-with-both () visual
199 (defun visual-get-best (&key depth type)
201 ((and depth type) (%visual-get-best-with-both depth type))
202 (depth (%visual-get-best-with-depth depth))
203 (type (%visual-get-best-with-type type))
204 (t (%visual-get-best-with-nothing))))
206 ;(define-foreign query-depths ..)
208 ;(define-foreign query-visual-types ..)
210 (define-foreign list-visuals () (glist visual))
215 ; (define-foreign window-new ... )
217 (define-foreign window-destroy () nil
221 ; (define-foreign window-at-pointer () window
226 (define-foreign window-show () nil
229 (define-foreign window-hide () nil
232 (define-foreign window-withdraw () nil
235 (define-foreign window-move () nil
240 (define-foreign window-resize () nil
245 (define-foreign window-move-resize () nil
252 (define-foreign window-reparent () nil
258 (define-foreign window-clear () nil
262 '(window-clear-area-no-e window-clear-area-e))
264 (define-foreign ("gdk_window_clear_area" window-clear-area-no-e) () nil
266 (x int) (y int) (width int) (height int))
268 (define-foreign window-clear-area-e () nil
270 (x int) (y int) (width int) (height int))
272 (defun window-clear-area (window x y width height &optional expose)
274 (window-clear-area-e window x y width height)
275 (window-clear-area-no-e window x y width height)))
277 ; (define-foreign window-copy-area () nil
282 ; (source-window window)
288 (define-foreign window-raise () nil
291 (define-foreign window-lower () nil
294 ; (define-foreign window-set-user-data () nil
296 (define-foreign window-set-override-redirect () nil
298 (override-redirect boolean))
300 ; (define-foreign window-add-filter () nil
302 ; (define-foreign window-remove-filter () nil
304 (define-foreign window-shape-combine-mask () nil
310 (define-foreign window-set-child-shapes () nil
313 (define-foreign window-merge-child-shapes () nil
316 (define-foreign ("gdk_window_is_visible" window-is-visible-p) () boolean
319 (define-foreign ("gdk_window_is_viewable" window-is-viewable-p) () boolean
322 (define-foreign window-set-static-gravities () boolean
324 (use-static boolean))
326 ; (define-foreign add-client-message-filter ...
331 (define-foreign drag-context-new () drag-context)
333 (define-foreign drag-context-ref () nil
334 (context drag-context))
336 (define-foreign drag-context-unref () nil
337 (context drag-context))
341 (define-foreign drag-status () nil
342 (context drag-context)
344 (time (unsigned 32)))
349 (define-foreign window-set-cursor () nil
353 (define-foreign window-get-pointer () window
357 (mask modifier-type :out))
359 (define-foreign get-root-window () window)
365 (define-foreign rgb-init () nil)
372 (deftype-method alien-ref cursor (type-spec)
373 (declare (ignore type-spec))
376 (deftype-method alien-unref cursor (type-spec)
377 (declare (ignore type-spec))
381 (define-foreign cursor-new () cursor
382 (cursor-type cursor-type))
384 (define-foreign cursor-new-from-pixmap () cursor
391 (define-foreign %cursor-ref () pointer
392 (cursor (or cursor pointer)))
394 (define-foreign %cursor-unref () nil
395 (cursor (or cursor pointer)))
401 ;; See the class definition for an explanation of this
402 (deftype-method alien-ref bitmap (type-spec)
403 (declare (ignore type-spec))
406 (deftype-method alien-unref bitmap (type-spec)
407 (declare (ignore type-spec))
410 (define-foreign %drawable-ref () pointer
411 (object (or bitmap pointer)))
413 (define-foreign %drawable-unref () nil
414 (object (or bitmap pointer)))
417 (define-foreign pixmap-new (width height depth &key window) pixmap
421 (window (or null window)))
423 (define-foreign %pixmap-colormap-create-from-xpm () pixmap
424 (window (or null window))
425 (colormap (or null colormap))
427 (color (or null color))
430 (define-foreign %pixmap-colormap-create-from-xpm-d () pixmap
431 (window (or null window))
432 (colormap (or null colormap))
434 (color (or null color))
435 (data (vector string)))
437 (defun pixmap-create (source &key color window colormap)
439 (if (not (or window colormap))
442 (multiple-value-bind (pixmap mask)
444 ((or string pathname)
445 (%pixmap-colormap-create-from-xpm
446 window colormap color (namestring (truename source))))
448 (%pixmap-colormap-create-from-xpm-d window colormap color source)))
449 (unreference-instance pixmap)
450 (unreference-instance mask)
451 (values pixmap mask))))
457 (defun %scale-value (value)
460 (float (truncate (* value 65535)))))
462 (defmethod initialize-instance ((color color) &rest initargs
464 (declare (ignore initargs))
466 (with-slots ((%red red) (%green green) (%blue blue)) color
468 %red (%scale-value red)
469 %green (%scale-value green)
470 %blue (%scale-value blue))))
473 (defun ensure-color (color)
479 'color :red (svref color 0) :green (svref color 1)
480 :blue (svref color 2)))))
486 (define-foreign font-load () font
489 (defun ensure-font (font)
493 (string (font-load font))))
495 (define-foreign fontset-load () font
496 (fontset-name string))
498 (define-foreign font-ref () font
501 (define-foreign font-unref () nil
504 (defun font-maybe-unref (font1 font2)
505 (unless (eq font1 font2)
508 (define-foreign font-id () int
511 (define-foreign ("gdk_font_equal" font-equalp) () boolean
515 (define-foreign string-width () int
519 (define-foreign text-width
520 (font text &aux (length (length text))) int
525 ; (define-foreign ("gdk_text_width_wc" text-width-wc)
526 ; (font text &aux (length (length text))) int
531 (define-foreign char-width () int
535 ; (define-foreign ("gdk_char_width_wc" char-width-wc) () int
540 (define-foreign string-measure () int
544 (define-foreign text-measure
545 (font text &aux (length (length text))) int
550 (define-foreign char-measure () int
554 (define-foreign string-height () int
558 (define-foreign text-height
559 (font text &aux (length (length text))) int
564 (define-foreign char-height () int
569 ;;; Drawing functions
571 (define-foreign draw-rectangle () nil
572 (drawable (or window pixmap bitmap))
573 (gc gc) (filled boolean)
574 (x int) (y int) (width int) (height int))
579 (define-foreign keyval-name () string
580 (keyval unsigned-int))
582 (define-foreign keyval-from-name () unsigned-int
585 (define-foreign keyval-to-upper () unsigned-int
586 (keyval unsigned-int))
588 (define-foreign keyval-to-lower ()unsigned-int
589 (keyval unsigned-int))
591 (define-foreign ("gdk_keyval_is_upper" keyval-is-upper-p) () boolean
592 (keyval unsigned-int))
594 (define-foreign ("gdk_keyval_is_lower" keyval-is-lower-p) () boolean
595 (keyval unsigned-int))