1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: gdk.lisp,v 1.32 2006-08-14 14:03:32 espen Exp $
30 (defbinding (gdk-init "gdk_parse_args") () nil
31 "Initializes the library without opening the display."
39 (defbinding %display-open () display
40 (display-name (or null string)))
42 (defun display-open (&optional display-name)
43 (let ((display (%display-open display-name)))
44 (unless (display-get-default)
45 (display-set-default display))
48 (defbinding %display-get-n-screens () int
51 (defbinding %display-get-screen () screen
55 (defun display-screens (&optional (display (display-get-default)))
57 for i from 0 below (%display-get-n-screens display)
58 collect (%display-get-screen display i)))
60 (defbinding display-get-default-screen
61 (&optional (display (display-get-default))) screen
64 (defbinding display-beep (&optional (display (display-get-default))) nil
67 (defbinding display-sync (&optional (display (display-get-default))) nil
70 (defbinding display-flush (&optional (display (display-get-default))) nil
73 (defbinding display-close (&optional (display (display-get-default))) nil
76 (defbinding display-get-event
77 (&optional (display (display-get-default))) event
80 (defbinding display-peek-event
81 (&optional (display (display-get-default))) event
84 (defbinding display-put-event
85 (event &optional (display (display-get-default))) event
89 (defbinding (display-connection-number "clg_gdk_connection_number")
90 (&optional (display (display-get-default))) int
97 (defbinding display-get-default () display)
99 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
101 (defbinding (display-set-default "gdk_display_manager_set_default_display")
103 ((display-manager) display-manager)
107 ;;; Primitive graphics structures (points, rectangles and regions)
109 (defbinding %rectangle-intersect () boolean
114 (defun rectangle-intersect (src1 src2 &optional (dest (make-instance 'rectangle)))
115 "Calculates the intersection of two rectangles. It is allowed for DEST to be the same as either SRC1 or SRC2. DEST is returned if the to rectangles intersect, otherwise NIL"
116 (when (%rectangle-intersect src1 src2 dest)
119 (defbinding rectangle-union (src1 src2 &optional (dest (make-instance 'rectangle))) nil
120 "Calculates the union of two rectangles. The union of rectangles SRC1 and SRC2 is the smallest rectangle which includes both SRC1 and SRC2 within it. It is allowed for DEST to be the same as either SRC1 or SRC2."
123 (dest rectangle :in/return))
125 (defun ensure-rectangle (rectangle)
127 (rectangle rectangle)
128 (vector (make-instance 'rectangle
129 :x (aref rectangle 0) :y (aref rectangle 1)
130 :width (aref rectangle 2) :height (aref rectangle 3)))))
133 (defbinding %region-new () pointer)
135 (defbinding %region-polygon () pointer
136 (points (vector (inlined point)))
138 (fill-rule fill-rule))
140 (defbinding %region-rectangle () pointer
141 (rectangle rectangle))
143 (defbinding %region-copy () pointer
146 (defbinding %region-destroy () nil
149 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
150 (declare (ignore initargs))
152 ((and rectangle polygon)
153 (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
154 (rectangle (%region-rectangle (ensure-rectangle rectangle)))
155 (polygon (%region-polygon polygon (length polygon) fill-rule))
158 (defun ensure-region (region)
161 ((or rectangle vector)
162 (make-instance 'region :rectangle (ensure-rectangle region)))))
164 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
166 (rectangle rectangle :in/return))
168 (defbinding %region-get-rectangles () nil
170 (rectangles pointer :out)
171 (n-rectangles int :out))
173 (defun region-get-rectangles (region)
174 "Obtains the area covered by the region as a list of rectangles."
175 (multiple-value-bind (location length) (%region-get-rectangles region)
177 (map-c-vector 'list #'identity location 'point length :get)
178 (deallocate-memory location))))
180 (defbinding region-empty-p () boolean
183 (defbinding region-equal-p () boolean
187 (defbinding region-point-in-p () boolean
192 (defbinding region-rect-in (region rectangle) overlap-type
194 ((ensure-rectangle rectangle) rectangle))
196 (defbinding region-offset () nil
201 (defbinding region-shrink () nil
206 (defbinding region-intersect (source1 source2) nil
208 ((ensure-region source2) region))
210 (defbinding region-union (source1 source2) nil
212 ((ensure-region source2) region))
214 (defbinding region-subtract (source1 source2) nil
216 ((ensure-region source2) region))
218 (defbinding region-xor (source1 source2) nil
220 ((ensure-region source2) region))
225 (defbinding (events-pending-p "gdk_events_pending") () boolean)
227 (defbinding event-get () event)
229 (defbinding event-peek () event)
231 (defbinding event-get-graphics-expose () event
234 (defbinding event-put () event
237 ;(defbinding event-handler-set () ...)
239 (defbinding set-show-events () nil
240 (show-events boolean))
242 (defbinding get-show-events () boolean)
245 ;;; Miscellaneous functions
247 (defbinding screen-width () int)
248 (defbinding screen-height () int)
250 (defbinding screen-width-mm () int)
251 (defbinding screen-height-mm () int)
253 (defbinding pointer-grab
254 (window &key owner-events events confine-to cursor time) grab-status
256 (owner-events boolean)
258 (confine-to (or null window))
259 (cursor (or null cursor))
260 ((or time 0) (unsigned 32)))
262 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
263 (&optional time (display (display-get-default))) nil
265 ((or time 0) (unsigned 32)))
267 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
268 (&optional (display (display-get-default))) boolean
271 (defbinding keyboard-grab (window &key owner-events time) grab-status
273 (owner-events boolean)
274 ((or time 0) (unsigned 32)))
276 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
277 (&optional time (display (display-get-default))) nil
279 ((or time 0) (unsigned 32)))
283 (defbinding atom-intern (atom-name &optional only-if-exists) atom
284 ((string atom-name) string)
285 (only-if-exists boolean))
287 (defbinding atom-name () string
294 (defbinding visual-get-best-depth () int)
296 (defbinding visual-get-best-type () visual-type)
298 (defbinding visual-get-system () visual)
301 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
303 (defbinding %visual-get-best-with-depth () visual
306 (defbinding %visual-get-best-with-type () visual
309 (defbinding %visual-get-best-with-both () visual
313 (defun visual-get-best (&key depth type)
315 ((and depth type) (%visual-get-best-with-both depth type))
316 (depth (%visual-get-best-with-depth depth))
317 (type (%visual-get-best-with-type type))
318 (t (%visual-get-best-with-nothing))))
320 ;(defbinding query-depths ..)
322 ;(defbinding query-visual-types ..)
324 (defbinding list-visuals () (glist visual))
329 (defbinding window-destroy () nil
332 (defbinding window-at-pointer () window
336 (defbinding window-show () nil
339 (defbinding window-show-unraised () nil
342 (defbinding window-hide () nil
345 (defbinding window-is-visible-p () boolean
348 (defbinding window-is-viewable-p () boolean
351 (defbinding window-withdraw () nil
354 (defbinding window-iconify () nil
357 (defbinding window-deiconify () nil
360 (defbinding window-stick () nil
363 (defbinding window-unstick () nil
366 (defbinding window-maximize () nil
369 (defbinding window-unmaximize () nil
372 (defbinding window-fullscreen () nil
375 (defbinding window-unfullscreen () nil
378 (defbinding window-set-keep-above () nil
382 (defbinding window-set-keep-below () nil
386 (defbinding window-move () nil
391 (defbinding window-resize () nil
396 (defbinding window-move-resize () nil
403 (defbinding window-scroll () nil
408 (defbinding window-reparent () nil
414 (defbinding window-clear () nil
417 (defbinding %window-clear-area () nil
419 (x int) (y int) (width int) (height int))
421 (defbinding %window-clear-area-e () nil
423 (x int) (y int) (width int) (height int))
425 (defun window-clear-area (window x y width height &optional expose)
427 (%window-clear-area-e window x y width height)
428 (%window-clear-area window x y width height)))
430 (defbinding window-raise () nil
433 (defbinding window-lower () nil
436 (defbinding window-focus () nil
438 (timestamp unsigned-int))
440 (defbinding window-register-dnd () nil
443 (defbinding window-begin-resize-drag () nil
449 (timestamp unsigned-int))
451 (defbinding window-begin-move-drag () nil
456 (timestamp unsigned-int))
458 ;; Probably not needed
459 ;; (defbinding window-constrain-size () nil ..
461 (defbinding window-begin-paint-region (window region) nil
463 ((ensure-region region) region))
465 (defbinding window-end-paint () nil
468 (defmacro with-window-paint ((window region) &body body)
470 (window-begin-paint-region ,window ,region)
473 (window-end-paint ,window))))
475 ;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse
476 ;; if last arg is a function
477 (defbinding window-invalidate-region (window region invalidate-children-p) nil
479 ((ensure-region region) region)
480 (invalidate-children-p boolean))
482 (defbinding window-get-update-area () region
485 (defbinding window-freeze-updates () nil
488 (defbinding window-thaw-updates () nil
491 (defbinding window-process-all-updates () nil)
493 (defbinding window-process-updates () nil
495 (update-children-p boolean))
497 (defbinding window-set-debug-updates () nil
500 (defbinding window-enable-synchronized-configure () nil
503 (defbinding window-configure-finished () nil
506 ;; Deprecated, use gobject user data mechanism
507 (defbinding window-set-user-data () nil
511 (defbinding window-set-override-redirect () nil
513 (override-redirect-p boolean))
515 (defbinding window-set-accept-focus () nil
517 (accept-focus-p boolean))
519 (defbinding window-set-focus-on-map () nil
521 (focus-on-map-p boolean))
524 ; (defbinding window-add-filter () nil
525 ; (defbinding window-remove-filter () nil
527 ;; New code should use window-shape-combine
528 (defbinding window-shape-combine-mask () nil
534 (defbinding %window-shape-combine-region () nil
536 (region (or null region))
540 (defun window-shape-combine (window shape offset-x offset-y)
542 (nil (%window-shape-combine-region window nil 0 0)
543 (region (%window-shape-combine-region window shape offset-x offset-y))
544 (bitmask (window-shape-combine-mask window shape offset-x offset-y)))))
546 (defbinding window-set-child-shapes () nil
549 (defbinding window-merge-child-shapes () nil
552 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
554 (defbinding %window-input-shape-combine-mask () nil
560 (defbinding %window-input-shape-combine-region () nil
562 (region (or null region))
566 (defun window-input-shape-combine (window shape x y)
568 (nil (%window-input-shape-combine-region window nil 0 0)
569 (region (%window-input-shape-combine-region window shape x y))
570 (bitmask (%window-input-shape-combine-mask window shape x y)))))
572 (defbinding window-set-child-input-shapes () nil
575 (defbinding window-merge-child-input-shapes () nil
578 (defbinding window-set-static-gravities () boolean
580 (use-static-p boolean))
582 (defbinding window-set-title () nil
586 (defbinding window-set-background () nil
590 (defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
592 (pixmap (or null pixmap))
593 (parent-relative-p boolean))
595 (defbinding window-set-cursor () nil
597 (cursor (or null cursor)))
599 (defbinding window-get-geometry () nil
607 ;(defbinding window-set-geometry-hints () nil
609 (defbinding window-set-icon-list () nil
611 (icons (glist pixbufs)))
613 (defbinding window-set-skip-taskbar-hint () nil
615 (skip-taskbar-p boolean))
617 (defbinding window-set-skip-pager-hint () nil
619 (skip-pager-p boolean))
621 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
622 (defbinding window-set-urgency-hint () nil
626 (defbinding window-get-position () nil
631 (defbinding window-get-root-origin () nil
636 (defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
638 (extents rectangle :in/return))
640 (defbinding window-get-origin () nil ; this may not work as
641 (window window) ; an int is actually returned
645 (defbinding window-get-pointer () window
649 (mask modifier-type :out))
651 ;(defbinding window-set-icon () nil
653 (defbinding window-set-icon-name () nil
657 (defbinding window-set-transient-for () nil
661 (defbinding window-set-role () nil
665 (defbinding %window-get-decorations () boolean
667 (decorations wm-decoration :out))
669 (defun %window-decorations-getter (window)
670 (nth-value 1 (%window-get-decorations window)))
672 (defun %window-decorations-boundp (window)
673 (%window-get-decorations window))
675 (defbinding %window-get-toplevels () (glist window))
677 (defun window-get-toplevels (&optional screen)
679 (error "Not implemented")
680 (%window-get-toplevels)))
682 (defbinding %get-default-root-window () window)
684 (defun get-root-window (&optional display)
686 (error "Not implemented")
687 (%get-default-root-window)))
695 (defbinding drag-status () nil
696 (context drag-context)
698 (time (unsigned 32)))
707 (defbinding rgb-init () nil)
714 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
715 (x 0) (y 0) (display (display-get-default)))
717 (keyword (%cursor-new-for-display display source))
718 (pixbuf (%cursor-new-from-pixbuf display source x y))
719 (pixmap (%cursor-new-from-pixmap source mask
720 (or fg (ensure-color #(0.0 0.0 0.0)))
721 (or bg (ensure-color #(1.0 1.0 1.0))) x y))
722 (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
724 (defun ensure-cursor (cursor &rest args)
725 (if (typep cursor 'cursor)
727 (apply #'make-instance 'cursor :source cursor args)))
729 (defbinding %cursor-new-for-display () pointer
731 (cursor-type cursor-type))
733 (defbinding %cursor-new-from-pixmap () pointer
740 (defbinding %cursor-new-from-pixbuf () pointer
745 (defbinding %cursor-ref () pointer
748 (defbinding %cursor-unref () nil
754 (defbinding %pixmap-new () pointer
755 (window (or null window))
760 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
761 (%pixmap-new window width height depth))
763 (defun pixmap-new (width height depth &key window)
764 (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
765 (make-instance 'pixmap :width width :height height :depth depth :window window))
767 (defbinding %pixmap-colormap-create-from-xpm () pixmap
768 (window (or null window))
769 (colormap (or null colormap))
771 (color (or null color))
774 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
775 (window (or null window))
776 (colormap (or null colormap))
778 (color (or null color))
779 (data (vector string)))
781 ;; Deprecated, use pixbufs instead
782 (defun pixmap-create (source &key color window colormap)
784 (if (not (or window colormap))
787 (multiple-value-bind (pixmap mask)
789 ((or string pathname)
790 (%pixmap-colormap-create-from-xpm window colormap color source))
792 (%pixmap-colormap-create-from-xpm-d window colormap color source)))
793 (values pixmap mask))))
798 (defbinding colormap-get-system () colormap)
800 (defbinding %color-copy () pointer
803 (defmethod allocate-foreign ((color color) &rest initargs)
804 (declare (ignore color initargs))
805 ;; Color structs are allocated as memory chunks by gdk, and since
806 ;; there is no gdk_color_new we have to use this hack to get a new
808 (with-memory (location #.(foreign-size (find-class 'color)))
809 (%color-copy location)))
811 (defun %scale-value (value)
814 (float (truncate (* value 65535)))))
816 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
818 (with-slots ((%red red) (%green green) (%blue blue)) color
820 %red (%scale-value red)
821 %green (%scale-value green)
822 %blue (%scale-value blue))))
824 (defbinding %color-parse () boolean
826 (color color :in/return))
828 (defun color-parse (spec &optional (color (make-instance 'color)))
829 (multiple-value-bind (succeeded-p color) (%color-parse spec color)
832 (error "Parsing color specification ~S failed." spec))))
834 (defun ensure-color (color)
838 (string (color-parse color))
840 (make-instance 'color
841 :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
845 ;;; Drawable -- all the draw- functions are deprecated and will be
846 ;;; removed, use cairo for drawing instead.
848 (defbinding drawable-get-size () nil
853 (defbinding (drawable-width "gdk_drawable_get_size") () nil
858 (defbinding (drawable-height "gdk_drawable_get_size") () nil
863 ;; (defbinding drawable-get-clip-region () region
864 ;; (drawable drawable))
866 ;; (defbinding drawable-get-visible-region () region
867 ;; (drawable drawable))
869 (defbinding draw-point () nil
870 (drawable drawable) (gc gc)
873 (defbinding %draw-points () nil
874 (drawable drawable) (gc gc)
878 (defbinding draw-line () nil
879 (drawable drawable) (gc gc)
883 (defbinding draw-pixbuf
884 (drawable gc pixbuf src-x src-y dest-x dest-y &optional
885 width height (dither :none) (x-dither 0) (y-dither 0)) nil
886 (drawable drawable) (gc (or null gc))
888 (src-x int) (src-y int)
889 (dest-x int) (dest-y int)
890 ((or width -1) int) ((or height -1) int)
892 (x-dither int) (y-dither int))
894 (defbinding draw-rectangle () nil
895 (drawable drawable) (gc gc)
898 (width int) (height int))
900 (defbinding draw-arc () nil
901 (drawable drawable) (gc gc)
904 (width int) (height int)
905 (angle1 int) (angle2 int))
907 (defbinding %draw-layout () nil
908 (drawable drawable) (gc gc)
911 (layout pango:layout))
913 (defbinding %draw-layout-with-colors () nil
914 (drawable drawable) (gc gc)
917 (layout pango:layout)
918 (foreground (or null color))
919 (background (or null color)))
921 (defun draw-layout (drawable gc font x y layout &optional foreground background)
922 (if (or foreground background)
923 (%draw-layout-with-colors drawable gc font x y layout foreground background)
924 (%draw-layout drawable gc font x y layout)))
926 (defbinding draw-drawable
927 (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
928 (drawable drawable) (gc gc)
930 (src-x int) (src-y int)
931 (dest-x int) (dest-y int)
932 ((or width -1) int) ((or height -1) int))
934 (defbinding draw-image
935 (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
936 (drawable drawable) (gc gc)
938 (src-x int) (src-y int)
939 (dest-x int) (dest-y int)
940 ((or width -1) int) ((or height -1) int))
942 (defbinding drawable-get-image () image
945 (width int) (height int))
947 (defbinding drawable-copy-to-image
948 (drawable src-x src-y width height &optional image dest-x dest-y) image
950 (image (or null image))
951 (src-x int) (src-y int)
952 ((if image dest-x 0) int)
953 ((if image dest-y 0) int)
954 (width int) (height int))
959 (defbinding keyval-name () string
960 (keyval unsigned-int))
962 (defbinding %keyval-from-name () unsigned-int
965 (defun keyval-from-name (name)
966 "Returns the keysym value for the given key name or NIL if it is not a valid name."
967 (let ((keyval (%keyval-from-name name)))
968 (unless (zerop keyval)
971 (defbinding keyval-to-upper () unsigned-int
972 (keyval unsigned-int))
974 (defbinding keyval-to-lower () unsigned-int
975 (keyval unsigned-int))
977 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
978 (keyval unsigned-int))
980 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
981 (keyval unsigned-int))
983 ;;; Cairo interaction
985 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
987 (defbinding cairo-create () cairo:context
990 (defmacro with-cairo-context ((cr drawable) &body body)
991 `(let ((,cr (cairo-create ,drawable)))
994 (invalidate-instance ,cr t))))
996 (defbinding cairo-set-source-color () nil
1000 (defbinding cairo-set-source-pixbuf () nil
1006 (defbinding cairo-rectangle () nil
1008 (rectangle rectangle))
1010 ;; (defbinding cairo-region () nil
1011 ;; (cr cairo:context)
1017 ;;; Multi-threading support
1021 (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
1022 (let ((recursive-level 0))
1023 (defun threads-enter ()
1024 (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
1025 (incf recursive-level)
1026 (sb-thread:get-mutex *global-lock*)))
1028 (defun threads-leave (&optional flush-p)
1030 ((zerop recursive-level)
1033 (sb-thread:release-mutex *global-lock*))
1034 (t (decf recursive-level)))))
1036 (define-callback %enter-fn nil ()
1039 (define-callback %leave-fn nil ()
1042 (defbinding threads-set-lock-functions (&optional) nil
1043 (%enter-fn callback)
1044 (%leave-fn callback))
1046 (defmacro with-global-lock (&body body)
1051 (threads-leave t)))))