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.28 2006-04-25 22:27:13 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)
110 (defbinding (events-pending-p "gdk_events_pending") () boolean)
112 (defbinding event-get () event)
114 (defbinding event-peek () event)
116 (defbinding event-get-graphics-expose () event
119 (defbinding event-put () event
122 ;(defbinding event-handler-set () ...)
124 (defbinding set-show-events () nil
125 (show-events boolean))
127 (defbinding get-show-events () boolean)
130 ;;; Miscellaneous functions
132 (defbinding screen-width () int)
133 (defbinding screen-height () int)
135 (defbinding screen-width-mm () int)
136 (defbinding screen-height-mm () int)
138 (defbinding pointer-grab
139 (window &key owner-events events confine-to cursor time) grab-status
141 (owner-events boolean)
143 (confine-to (or null window))
144 (cursor (or null cursor))
145 ((or time 0) (unsigned 32)))
147 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
148 (&optional time (display (display-get-default))) nil
150 ((or time 0) (unsigned 32)))
152 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
153 (&optional (display (display-get-default))) boolean
156 (defbinding keyboard-grab (window &key owner-events time) grab-status
158 (owner-events boolean)
159 ((or time 0) (unsigned 32)))
161 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
162 (&optional time (display (display-get-default))) nil
164 ((or time 0) (unsigned 32)))
168 (defbinding atom-intern (atom-name &optional only-if-exists) atom
169 ((string atom-name) string)
170 (only-if-exists boolean))
172 (defbinding atom-name () string
179 (defbinding visual-get-best-depth () int)
181 (defbinding visual-get-best-type () visual-type)
183 (defbinding visual-get-system () visual)
186 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
188 (defbinding %visual-get-best-with-depth () visual
191 (defbinding %visual-get-best-with-type () visual
194 (defbinding %visual-get-best-with-both () visual
198 (defun visual-get-best (&key depth type)
200 ((and depth type) (%visual-get-best-with-both depth type))
201 (depth (%visual-get-best-with-depth depth))
202 (type (%visual-get-best-with-type type))
203 (t (%visual-get-best-with-nothing))))
205 ;(defbinding query-depths ..)
207 ;(defbinding query-visual-types ..)
209 (defbinding list-visuals () (glist visual))
214 (defbinding window-destroy () nil
218 (defbinding window-at-pointer () window
222 (defbinding window-show () nil
225 (defbinding window-show-unraised () nil
228 (defbinding window-hide () nil
231 (defbinding window-is-visible-p () boolean
234 (defbinding window-is-viewable-p () boolean
237 (defbinding window-withdraw () nil
240 (defbinding window-iconify () nil
243 (defbinding window-deiconify () nil
246 (defbinding window-stick () nil
249 (defbinding window-unstick () nil
252 (defbinding window-maximize () nil
255 (defbinding window-unmaximize () nil
258 (defbinding window-fullscreen () nil
261 (defbinding window-unfullscreen () nil
264 (defbinding window-set-keep-above () nil
268 (defbinding window-set-keep-below () nil
272 (defbinding window-move () nil
277 (defbinding window-resize () nil
282 (defbinding window-move-resize () nil
289 (defbinding window-scroll () nil
294 (defbinding window-reparent () nil
300 (defbinding window-clear () nil
303 (defbinding %window-clear-area () nil
305 (x int) (y int) (width int) (height int))
307 (defbinding %window-clear-area-e () nil
309 (x int) (y int) (width int) (height int))
311 (defun window-clear-area (window x y width height &optional expose)
313 (%window-clear-area-e window x y width height)
314 (%window-clear-area window x y width height)))
316 (defbinding window-raise () nil
319 (defbinding window-lower () nil
322 (defbinding window-focus () nil
324 (timestamp unsigned-int))
326 (defbinding window-register-dnd () nil
329 (defbinding window-begin-resize-drag () nil
335 (timestamp unsigned-int))
337 (defbinding window-begin-move-drag () nil
342 (timestamp unsigned-int))
346 (defbinding window-set-user-data () nil
350 (defbinding window-set-override-redirect () nil
352 (override-redirect boolean))
354 ; (defbinding window-add-filter () nil
356 ; (defbinding window-remove-filter () nil
358 (defbinding window-shape-combine-mask () nil
364 (defbinding window-set-child-shapes () nil
367 (defbinding window-merge-child-shapes () nil
371 (defbinding window-set-static-gravities () boolean
373 (use-static boolean))
375 ; (defbinding add-client-message-filter ...
377 (defbinding window-set-cursor () nil
379 (cursor (or null cursor)))
381 (defbinding window-get-pointer () window
385 (mask modifier-type :out))
387 (defbinding %window-get-toplevels () (glist window))
389 (defun window-get-toplevels (&optional screen)
391 (error "Not implemented")
392 (%window-get-toplevels)))
394 (defbinding %get-default-root-window () window)
396 (defun get-root-window (&optional display)
398 (error "Not implemented")
399 (%get-default-root-window)))
407 (defbinding drag-status () nil
408 (context drag-context)
410 (time (unsigned 32)))
419 (defbinding rgb-init () nil)
426 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
427 (x 0) (y 0) (display (display-get-default)))
429 (keyword (%cursor-new-for-display display source))
430 (pixbuf (%cursor-new-from-pixbuf display source x y))
431 (pixmap (%cursor-new-from-pixmap source mask
432 (or fg (ensure-color #(0.0 0.0 0.0)))
433 (or bg (ensure-color #(1.0 1.0 1.0))) x y))
434 (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
436 (defun ensure-cursor (cursor &rest args)
437 (if (typep cursor 'cursor)
439 (apply #'make-instance 'cursor :type cursor args)))
441 (defbinding %cursor-new-for-display () pointer
443 (cursor-type cursor-type))
445 (defbinding %cursor-new-from-pixmap () pointer
452 (defbinding %cursor-new-from-pixbuf () pointer
457 (defbinding %cursor-ref () pointer
460 (defbinding %cursor-unref () nil
466 (defbinding pixmap-new (width height depth &key window) pixmap
470 (window (or null window)))
472 (defbinding %pixmap-colormap-create-from-xpm () pixmap
473 (window (or null window))
474 (colormap (or null colormap))
476 (color (or null color))
479 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
480 (window (or null window))
481 (colormap (or null colormap))
483 (color (or null color))
484 (data (vector string)))
486 (defun pixmap-create (source &key color window colormap)
488 (if (not (or window colormap))
491 (multiple-value-bind (pixmap mask)
493 ((or string pathname)
494 (%pixmap-colormap-create-from-xpm window colormap color source))
496 (%pixmap-colormap-create-from-xpm-d window colormap color source)))
497 (values pixmap mask))))
503 (defbinding %color-copy () pointer
506 (defmethod allocate-foreign ((color color) &rest initargs)
507 (declare (ignore color initargs))
508 ;; Color structs are allocated as memory chunks by gdk, and since
509 ;; there is no gdk_color_new we have to use this hack to get a new
511 (with-memory (location #.(foreign-size (find-class 'color)))
512 (%color-copy location)))
514 (defun %scale-value (value)
517 (float (truncate (* value 65535)))))
519 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
521 (with-slots ((%red red) (%green green) (%blue blue)) color
523 %red (%scale-value red)
524 %green (%scale-value green)
525 %blue (%scale-value blue))))
527 (defbinding %color-parse () boolean
529 (color color :in/return))
531 (defun color-parse (spec &optional (color (make-instance 'color)))
532 (multiple-value-bind (succeeded-p color) (%color-parse spec color)
535 (error "Parsing color specification ~S failed." spec))))
537 (defun ensure-color (color)
541 (string (color-parse color))
543 (make-instance 'color
544 :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
548 ;;; Drawable -- all the draw- functions are dprecated and will be
549 ;;; removed, use cairo for drawing instead.
551 (defbinding drawable-get-size () nil
556 (defbinding (drawable-width "gdk_drawable_get_size") () nil
561 (defbinding (drawable-height "gdk_drawable_get_size") () nil
566 ;; (defbinding drawable-get-clip-region () region
567 ;; (drawable drawable))
569 ;; (defbinding drawable-get-visible-region () region
570 ;; (drawable drawable))
572 (defbinding draw-point () nil
573 (drawable drawable) (gc gc)
576 (defbinding %draw-points () nil
577 (drawable drawable) (gc gc)
581 (defbinding draw-line () nil
582 (drawable drawable) (gc gc)
586 (defbinding draw-pixbuf
587 (drawable gc pixbuf src-x src-y dest-x dest-y &optional
588 width height (dither :none) (x-dither 0) (y-dither 0)) nil
589 (drawable drawable) (gc (or null gc))
591 (src-x int) (src-y int)
592 (dest-x int) (dest-y int)
593 ((or width -1) int) ((or height -1) int)
595 (x-dither int) (y-dither int))
597 (defbinding draw-rectangle () nil
598 (drawable drawable) (gc gc)
601 (width int) (height int))
603 (defbinding draw-arc () nil
604 (drawable drawable) (gc gc)
607 (width int) (height int)
608 (angle1 int) (angle2 int))
610 (defbinding %draw-layout () nil
611 (drawable drawable) (gc gc)
614 (layout pango:layout))
616 (defbinding %draw-layout-with-colors () nil
617 (drawable drawable) (gc gc)
620 (layout pango:layout)
621 (foreground (or null color))
622 (background (or null color)))
624 (defun draw-layout (drawable gc font x y layout &optional foreground background)
625 (if (or foreground background)
626 (%draw-layout-with-colors drawable gc font x y layout foreground background)
627 (%draw-layout drawable gc font x y layout)))
629 (defbinding draw-drawable
630 (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
631 (drawable drawable) (gc gc)
633 (src-x int) (src-y int)
634 (dest-x int) (dest-y int)
635 ((or width -1) int) ((or height -1) int))
637 (defbinding draw-image
638 (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
639 (drawable drawable) (gc gc)
641 (src-x int) (src-y int)
642 (dest-x int) (dest-y int)
643 ((or width -1) int) ((or height -1) int))
645 (defbinding drawable-get-image () image
648 (width int) (height int))
650 (defbinding drawable-copy-to-image
651 (drawable src-x src-y width height &optional image dest-x dest-y) image
653 (image (or null image))
654 (src-x int) (src-y int)
655 ((if image dest-x 0) int)
656 ((if image dest-y 0) int)
657 (width int) (height int))
662 (defbinding keyval-name () string
663 (keyval unsigned-int))
665 (defbinding %keyval-from-name () unsigned-int
668 (defun keyval-from-name (name)
669 "Returns the keysym value for the given key name or NIL if it is not a valid name."
670 (let ((keyval (%keyval-from-name name)))
671 (unless (zerop keyval)
674 (defbinding keyval-to-upper () unsigned-int
675 (keyval unsigned-int))
677 (defbinding keyval-to-lower () unsigned-int
678 (keyval unsigned-int))
680 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
681 (keyval unsigned-int))
683 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
684 (keyval unsigned-int))
686 ;;; Cairo interaction
688 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
690 (defbinding cairo-create () cairo:context
693 (defmacro with-cairo-context ((cr drawable) &body body)
694 `(let ((,cr (cairo-create ,drawable)))
697 (invalidate-instance ,cr t))))
699 (defbinding cairo-set-source-color () nil
703 (defbinding cairo-set-source-pixbuf () nil
709 (defbinding cairo-rectangle () nil
711 (rectangle rectangle))
713 ;; (defbinding cairo-region () nil
714 ;; (cr cairo:context)
720 ;;; Multi-threading support
724 (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
725 (let ((recursive-level 0))
726 (defun threads-enter ()
727 (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
728 (incf recursive-level)
729 (sb-thread:get-mutex *global-lock*)))
731 (defun threads-leave (&optional flush-p)
733 ((zerop recursive-level)
736 (sb-thread:release-mutex *global-lock*))
737 (t (decf recursive-level)))))
739 (define-callback %enter-fn nil ()
742 (define-callback %leave-fn nil ()
745 (defbinding threads-set-lock-functions (&optional) nil
747 (%leave-fn callback))
749 (defmacro with-global-lock (&body body)
754 (threads-leave t)))))