X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/0d270bd94e469f012bfab2022aaca91dc9b953c3..3b1ba4821b848ca134d8ff2a97c90401d584a5ae:/gtk/gtkwidget.lisp

diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp
index 709421b..1559fe0 100644
--- a/gtk/gtkwidget.lisp
+++ b/gtk/gtkwidget.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 2000-2002 Espen S. Johnsen <espen@users.sourceforge.net>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -15,29 +15,30 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkwidget.lisp,v 1.4 2001-05-29 15:58:24 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.11 2004-12-17 00:27:01 espen Exp $
 
 (in-package "GTK")
 
 
-(defmethod initialize-instance ((widget widget) &rest initargs &key parent)
-  (declare (ignore initargs))
-  (call-next-method)
-  (cond
-   ((consp parent)
-    (with-slots ((container parent) child-slots) widget
-      (setf
-       container (car parent)
-       child-slots
-       (apply
-	#'make-instance
-	(slot-value (class-of container) 'child-class)
-	:parent container :child widget (cdr parent)))))
-   (parent
-    (setf (slot-value widget 'parent) parent))))
+(defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
+  (remf initargs :parent)
+  (prog1
+      (apply #'call-next-method widget names initargs)
+    (when parent
+      (when (slot-boundp widget 'parent)
+	(container-remove (widget-parent widget) widget))
+      (let ((parent-widget (first (mklist parent)))
+	    (args (rest (mklist parent))))
+	(apply #'container-add parent-widget widget args)))))
 
+(defmethod shared-initialize :after ((widget widget) names &rest initargs
+				     &key show-all all-visible)
+  (declare (ignore initargs names))
+  (when (or all-visible show-all)
+    (widget-show-all widget)))
 
-(defmethod slot-unbound ((class gobject) (object widget) slot)
+
+(defmethod slot-unbound ((class gobject-class) (object widget) slot)
   (cond
    ((and (eq slot 'child-slots) (slot-value object 'parent))
     (with-slots (parent child-slots) object
@@ -59,9 +60,13 @@
   `(with-slots ,slots (widget-child-slots ,widget)
      ,@body))
 
+
 (defmacro widget-destroyed (place)
   `(setf ,place nil))
 
+
+;;; Bindings
+
 (defbinding widget-destroy () nil
   (widget widget))
 
@@ -95,6 +100,25 @@
 (defbinding widget-unrealize () nil
   (widget widget))
 
+(defbinding widget-queue-draw () nil
+  (widget widget))
+
+(defbinding widget-queue-resize () nil
+  (widget widget))
+
+(defbinding widget-size-request () nil
+  (widget widget)
+  (requisition requisition))
+
+(defbinding widget-get-child-requisition () nil
+  (widget widget)
+  (requisition requisition))
+
+(defbinding widget-size-allocate () nil
+  (widget widget)
+  (allocation allocation))
+
+
 (defbinding widget-add-accelerator
     (widget signal accel-group key modifiers flags) nil
   (widget widget)
@@ -111,46 +135,38 @@
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 
-(defbinding widget-accelerator-signal
-    (widget accel-group key modifiers) unsigned-int
+(defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
   (widget widget)
-  (accel-group accel-group)
-  ((gdk:keyval-from-name key) unsigned-int)
-  (modifiers gdk:modifier-type))
-
-(defbinding widget-lock-accelerators () nil
-  (widget widget))
-
-(defbinding widget-unlock-accelerators () nil
-  (widget widget))
-
-(defbinding (widget-accelerators-locked-p "gtk_widget_accelerators_locked")
-    () boolean
-  (widget widget))
+  (accel-path string)
+  (accel-group accel-group))
+  
 
 (defbinding widget-event () int
   (widget widget)
   (event gdk:event))
 
-(defbinding get-event-widget () widget
-  (event gdk:event))
-
 (defbinding widget-activate () boolean
   (widget widget))
 
-(defbinding widget-set-scroll-adjustments () boolean
-  (widget widget)
-  (hadjustment adjustment)
-  (vadjustment adjustment))
-
 (defbinding widget-reparent () nil
   (widget widget)
   (new-parent widget))
 
-; (defbinding widget-popup () nil
-;   (widget widget)
-;   (x int)
-;   (y int))
+(defbinding %widget-intersect () boolean
+  (widget widget)
+  (area gdk:rectangle)
+  (intersection (or null gdk:rectangle)))
+
+(defun widget-intersection (widget area)
+  (let ((intersection (make-instance 'gdk:rectangle)))
+    (when (%widget-intersect widget area intersection)
+      intersection)))
+
+(defun widget-intersect-p (widget area)
+  (%widget-intersect widget area nil))
+
+;; (defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
+;;   (widget widget))
 
 (defbinding widget-grab-focus () nil
   (widget widget))
@@ -158,124 +174,215 @@
 (defbinding widget-grab-default () nil
   (widget widget))
 
-(defbinding grab-add () nil
+(defbinding widget-add-events () nil
+  (widget widget)
+  (events gdk:event-mask))
+
+(defbinding widget-get-toplevel () widget
   (widget widget))
 
-(defbinding grab-get-current () widget)
+(defbinding widget-get-ancestor (widget type) widget
+  (widget widget)
+  ((find-type-number type) type-number))
+
+(defbinding widget-get-pointer () nil
+  (widget widget)
+  (x int :out)
+  (y int :out))
+
+(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
+  (widget widget)
+  (ancestor widget))
+
+(defbinding widget-translate-coordinates () boolean
+  (src-widget widget)
+  (dest-widget widget)
+  (src-x int) (src-y int)
+  (set-x int :out) (dest-y int :out))
+
+(defun widget-hide-on-delete (widget)
+  "Utility function; intended to be connected to the DELETE-EVENT
+signal on a GtkWindow. The function calls WIDGET-HIDE on its
+argument, then returns T. If connected to DELETE-EVENT, the
+result is that clicking the close button for a window (on the window
+frame, top right corner usually) will hide but not destroy the
+window. By default, GTK+ destroys windows when DELETE-EVENT is
+received."
+  (widget-hide widget)
+  t)
+  
+(defbinding widget-ensure-style () nil
+  (widget widget))
 
-(defbinding grab-remove () nil
+(defbinding widget-reset-rc-styles () nil
   (widget widget))
 
-(defbinding widget-allocation () nil
+(defbinding widget-push-colormap () nil
+  (colormap gdk:colormap))
+
+(defbinding widget-pop-colormap () nil)
+
+(defbinding widget-set-default-colormap () nil
+  (colormap gdk:colormap))
+
+(defbinding widget-get-default-style () style)
+
+(defbinding widget-get-default-colormap () gdk:colormap)
+
+(defbinding widget-get-default-visual () gdk:visual)
+
+(defbinding widget-get-default-direction () text-direction)
+
+(defbinding widget-set-default-direction () nil
+  (direction  text-direction))
+
+(defbinding widget-shape-combine-mask () nil
   (widget widget)
-  (width int :out)
-  (height int :out))
+  (shape-mask gdk:bitmap)
+  (x-offset int)
+  (y-offset int))
 
+(defbinding widget-path () nil
+  (widget widget)
+  (path-length int :out)
+  (path string :out)
+  (reverse-path string :out))
 
-(defbinding widget-set-uposition (widget &key (x t) (y t)) nil
+(defbinding widget-class-path () nil
   (widget widget)
-  ((case x
-     ((t) -2)
-     ((nil) -1)
-     (otherwise x)) int)
-  ((case y
-     ((t) -2)
-     ((nil) -1)
-     (otherwise y)) int))
+  (path-length int :out)
+  (path string :out)
+  (reverse-path string :out))
 
-(defbinding widget-add-events () nil
+(defbinding widget-modify-style () nil
   (widget widget)
-  (events gdk:event-mask))
+  (style rc-style))
 
-(defbinding (widget-toplevel "gtk_widget_get_toplevel") () widget
+(defbinding widget-modify-style () rc-style
   (widget widget))
 
-(defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget
+(defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
   (widget widget)
-  ((find-type-number type) type-number))
+  (state state-type)
+  (color gdk:color))
 
-; (defbinding ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
-;   (widget widget))
+(defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
+  (widget widget)
+  (state state-type)
+  (color gdk:color))
 
-; (defbinding ("gtk_widget_get_visual" widget-visual) () gdk:visual
-;   (widget widget))
+(defbinding widget-modify-text () nil
+  (widget widget)
+  (state state-type)
+  (color gdk:color))
 
-(defbinding (widget-pointer "gtk_widget_get_pointer") () nil
+(defbinding widget-modify-base () nil
   (widget widget)
-  (x int :out)
-  (y int :out))
+  (state state-type)
+  (color gdk:color))
 
-(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
+(defbinding widget-modify-font () nil
   (widget widget)
-  (ancestor widget))
+  (state state-type)
+  (font-desc pango:font-description))
 
-(defbinding widget-set-rc-style () nil
+(defbinding widget-create-pango-context () pango:context
   (widget widget))
 
-(defbinding widget-ensure-style () nil
+(defbinding widget-get-pango-context () pango:context
   (widget widget))
 
-(defbinding widget-restore-default-style () nil
-  (widget widget))
+(defbinding widget-create-pango-layout (widget &optional text) pango:layout
+  (widget widget)
+  (text (or string null)))
 
-(defbinding widget-reset-rc-styles () nil
-  (widget widget))
+(defbinding widget-render-icon () gdk:pixbuf
+  (widget widget)
+  (stock-id string)
+  (size icon-size)
+  (detail string))
 
-(defun (setf widget-cursor) (cursor-type widget)
-  (let ((cursor (gdk:cursor-new cursor-type))
-	(window (widget-window widget)))
-    (gdk:window-set-cursor window cursor)
-    ;(gdk:cursor-destroy cursor)
-    ))
+(defbinding widget-push-composite-child () nil)
 
-;; Push/pop pairs, to change default values upon a widget's creation.
-;; This will override the values that got set by the
-;; widget-set-default-* functions.
+(defbinding widget-pop-composite-child () nil)
 
-(defbinding widget-push-style () nil
-  (style style))
+(defbinding widget-queue-draw-area () nil
+  (widget widget)
+  (x int) (y int) (width int) (height int))
 
-(defbinding widget-push-colormap () nil
-  (colormap gdk:colormap))
+(defbinding widget-reset-shapes () nil
+  (widget widget))
 
-; (defbinding widget-push-visual () nil
-;   (visual gdk:visual))
+(defbinding widget-set-double-buffered () nil
+  (widget widget)
+  (double-buffered boolean))
 
-(defbinding widget-push-composite-child () nil)
+(defbinding widget-set-redraw-on-allocate () nil
+  (widget widget)
+  (redraw-on-allocate boolean))
 
-(defbinding widget-pop-style () nil)
+(defbinding widget-set-scroll-adjustments () boolean
+  (widget widget)
+  (hadjustment adjustment)
+  (vadjustment adjustment))
 
-(defbinding widget-pop-colormap () nil)
+(defbinding widget-mnemonic-activate () boolean
+  (widget widget)
+  (group-cycling boolean))
 
-;(defbinding widget-pop-visual () nil)
+(defbinding widget-region-intersect () pointer ;gdk:region
+  (widget widget)
+  (region pointer)) ;gdk:region))
 
-(defbinding widget-pop-composite-child () nil)
+(defbinding widget-send-expose () int
+  (widget widget)
+  (event gdk:event))
 
+(defbinding widget-get-accessible () atk:object
+  (widget widget))
 
-;; Set certain default values to be used at widget creation time.
+(defbinding widget-child-focus () boolean
+  (widget widget)
+  (direction direction-type))
 
-(defbinding widget-set-default-style () nil
-  (style style))
+(defbinding widget-child-notify () nil
+  (widget widget)
+  (child-property string))
 
-(defbinding widget-set-default-colormap () nil
-  (colormap gdk:colormap))
+(defbinding widget-freeze-child-notify () nil
+  (widget widget))
 
-; (defbinding widget-set-default-visual () nil
-;   (visual gdk:visual))
+(defbinding %widget-get-size-request () nil
+  (widget widget)
+  (width int :out)
+  (height int :out))
 
-(defbinding widget-get-default-style () style)
+(defun widget-get-size-request (widget)
+  (multiple-value-bind (width height) (%widget-get-size-request widget)
+     (values (unless (= width -1) width) (unless (= height -1) height))))
 
-(defbinding widget-get-default-colormap () gdk:colormap)
+(defbinding widget-set-size-request (widget width height) nil
+  (widget widget)
+  ((or width -1) int)
+  ((or height -1) int))
 
-(defbinding widget-get-default-visual () gdk:visual)
+(defbinding widget-thaw-child-notify () nil
+  (widget widget))
 
-(defbinding widget-shape-combine-mask () nil
-  (widget widget)
-  (shape-mask gdk:bitmap)
-  (x-offset int)
-  (y-offset int))
 
-;; defined in gtkglue.c
-(defbinding widget-mapped-p () boolean
+;;; Additional bindings and functions
+
+(defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
   (widget widget))
 
+(defbinding widget-get-size-allocation () nil
+  (widget widget)
+  (width int :out)
+  (height int :out))
+
+(defbinding get-event-widget () widget
+  (event gdk:event))
+
+(defun (setf widget-cursor) (cursor-type widget)
+  (let ((cursor (make-instance 'cursor  :type cursor-type)))
+    (gdk:window-set-cursor (widget-window widget) cursor)))