chiark - git - mdw - clg/blob - gtk/gtkwidget.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2002 Espen S. Johnsen <espen@users.sourceforge.net>
   3 ;;
   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.
   8 ;;
   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.
  13 ;;
  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
  17
  18 ;; $Id: gtkwidget.lisp,v 1.11 2004/12/17 00:27:01 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  23 (defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
  24   (remf initargs :parent)
  25   (prog1
  26       (apply #'call-next-method widget names initargs)
  27     (when parent
  28       (when (slot-boundp widget 'parent)
  29         (container-remove (widget-parent widget) widget))
  30       (let ((parent-widget (first (mklist parent)))
  31             (args (rest (mklist parent))))
  32         (apply #'container-add parent-widget widget args)))))
  33
  34 (defmethod shared-initialize :after ((widget widget) names &rest initargs
  35                                      &key show-all all-visible)
  36   (declare (ignore initargs names))
  37   (when (or all-visible show-all)
  38     (widget-show-all widget)))
  39
  40
  41 (defmethod slot-unbound ((class gobject-class) (object widget) slot)
  42   (cond
  43    ((and (eq slot 'child-slots) (slot-value object 'parent))
  44     (with-slots (parent child-slots) object
  45       (setf
  46        child-slots
  47        (make-instance
  48         (gethash (class-of parent) *container-to-child-class-mappings*)
  49         :parent parent :child object))))
  50    (t (call-next-method))))
  51
  52
  53 (defun child-slot-value (widget slot)
  54   (slot-value (widget-child-slots widget) slot))
  55
  56 (defun (setf child-slot-value) (value widget slot)
  57   (setf (slot-value (widget-child-slots widget) slot) value))
  58
  59 (defmacro with-child-slots (slots widget &body body)
  60   `(with-slots ,slots (widget-child-slots ,widget)
  61      ,@body))
  62
  63
  64 (defmacro widget-destroyed (place)
  65   `(setf ,place nil))
  66
  67
  68 ;;; Bindings
  69
  70 (defbinding widget-destroy () nil
  71   (widget widget))
  72
  73 (defbinding widget-unparent () nil
  74   (widget widget))
  75
  76 (defbinding widget-show () nil
  77   (widget widget))
  78
  79 (defbinding widget-show-now () nil
  80   (widget widget))
  81
  82 (defbinding widget-hide () nil
  83   (widget widget))
  84
  85 (defbinding widget-show-all () nil
  86   (widget widget))
  87
  88 (defbinding widget-hide-all () nil
  89   (widget widget))
  90
  91 (defbinding widget-map () nil
  92   (widget widget))
  93
  94 (defbinding widget-unmap () nil
  95   (widget widget))
  96
  97 (defbinding widget-realize () nil
  98   (widget widget))
  99
 100 (defbinding widget-unrealize () nil
 101   (widget widget))
 102
 103 (defbinding widget-queue-draw () nil
 104   (widget widget))
 105
 106 (defbinding widget-queue-resize () nil
 107   (widget widget))
 108
 109 (defbinding widget-size-request () nil
 110   (widget widget)
 111   (requisition requisition))
 112
 113 (defbinding widget-get-child-requisition () nil
 114   (widget widget)
 115   (requisition requisition))
 116
 117 (defbinding widget-size-allocate () nil
 118   (widget widget)
 119   (allocation allocation))
 120
 121
 122 (defbinding widget-add-accelerator
 123     (widget signal accel-group key modifiers flags) nil
 124   (widget widget)
 125   ((name-to-string signal) string)
 126   (accel-group accel-group)
 127   ((gdk:keyval-from-name key) unsigned-int)
 128   (modifiers gdk:modifier-type)
 129   (flags accel-flags))
 130
 131 (defbinding widget-remove-accelerator
 132     (widget accel-group key modifiers) nil
 133   (widget widget)
 134   (accel-group accel-group)
 135   ((gdk:keyval-from-name key) unsigned-int)
 136   (modifiers gdk:modifier-type))
 137
 138 (defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
 139   (widget widget)
 140   (accel-path string)
 141   (accel-group accel-group))
 142
 143
 144 (defbinding widget-event () int
 145   (widget widget)
 146   (event gdk:event))
 147
 148 (defbinding widget-activate () boolean
 149   (widget widget))
 150
 151 (defbinding widget-reparent () nil
 152   (widget widget)
 153   (new-parent widget))
 154
 155 (defbinding %widget-intersect () boolean
 156   (widget widget)
 157   (area gdk:rectangle)
 158   (intersection (or null gdk:rectangle)))
 159
 160 (defun widget-intersection (widget area)
 161   (let ((intersection (make-instance 'gdk:rectangle)))
 162     (when (%widget-intersect widget area intersection)
 163       intersection)))
 164
 165 (defun widget-intersect-p (widget area)
 166   (%widget-intersect widget area nil))
 167
 168 ;; (defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
 169 ;;   (widget widget))
 170
 171 (defbinding widget-grab-focus () nil
 172   (widget widget))
 173
 174 (defbinding widget-grab-default () nil
 175   (widget widget))
 176
 177 (defbinding widget-add-events () nil
 178   (widget widget)
 179   (events gdk:event-mask))
 180
 181 (defbinding widget-get-toplevel () widget
 182   (widget widget))
 183
 184 (defbinding widget-get-ancestor (widget type) widget
 185   (widget widget)
 186   ((find-type-number type) type-number))
 187
 188 (defbinding widget-get-pointer () nil
 189   (widget widget)
 190   (x int :out)
 191   (y int :out))
 192
 193 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
 194   (widget widget)
 195   (ancestor widget))
 196
 197 (defbinding widget-translate-coordinates () boolean
 198   (src-widget widget)
 199   (dest-widget widget)
 200   (src-x int) (src-y int)
 201   (set-x int :out) (dest-y int :out))
 202
 203 (defun widget-hide-on-delete (widget)
 204   "Utility function; intended to be connected to the DELETE-EVENT
 205 signal on a GtkWindow. The function calls WIDGET-HIDE on its
 206 argument, then returns T. If connected to DELETE-EVENT, the
 207 result is that clicking the close button for a window (on the window
 208 frame, top right corner usually) will hide but not destroy the
 209 window. By default, GTK+ destroys windows when DELETE-EVENT is
 210 received."
 211   (widget-hide widget)
 212   t)
 213
 214 (defbinding widget-ensure-style () nil
 215   (widget widget))
 216
 217 (defbinding widget-reset-rc-styles () nil
 218   (widget widget))
 219
 220 (defbinding widget-push-colormap () nil
 221   (colormap gdk:colormap))
 222
 223 (defbinding widget-pop-colormap () nil)
 224
 225 (defbinding widget-set-default-colormap () nil
 226   (colormap gdk:colormap))
 227
 228 (defbinding widget-get-default-style () style)
 229
 230 (defbinding widget-get-default-colormap () gdk:colormap)
 231
 232 (defbinding widget-get-default-visual () gdk:visual)
 233
 234 (defbinding widget-get-default-direction () text-direction)
 235
 236 (defbinding widget-set-default-direction () nil
 237   (direction  text-direction))
 238
 239 (defbinding widget-shape-combine-mask () nil
 240   (widget widget)
 241   (shape-mask gdk:bitmap)
 242   (x-offset int)
 243   (y-offset int))
 244
 245 (defbinding widget-path () nil
 246   (widget widget)
 247   (path-length int :out)
 248   (path string :out)
 249   (reverse-path string :out))
 250
 251 (defbinding widget-class-path () nil
 252   (widget widget)
 253   (path-length int :out)
 254   (path string :out)
 255   (reverse-path string :out))
 256
 257 (defbinding widget-modify-style () nil
 258   (widget widget)
 259   (style rc-style))
 260
 261 (defbinding widget-modify-style () rc-style
 262   (widget widget))
 263
 264 (defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
 265   (widget widget)
 266   (state state-type)
 267   (color gdk:color))
 268
 269 (defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
 270   (widget widget)
 271   (state state-type)
 272   (color gdk:color))
 273
 274 (defbinding widget-modify-text () nil
 275   (widget widget)
 276   (state state-type)
 277   (color gdk:color))
 278
 279 (defbinding widget-modify-base () nil
 280   (widget widget)
 281   (state state-type)
 282   (color gdk:color))
 283
 284 (defbinding widget-modify-font () nil
 285   (widget widget)
 286   (state state-type)
 287   (font-desc pango:font-description))
 288
 289 (defbinding widget-create-pango-context () pango:context
 290   (widget widget))
 291
 292 (defbinding widget-get-pango-context () pango:context
 293   (widget widget))
 294
 295 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
 296   (widget widget)
 297   (text (or string null)))
 298
 299 (defbinding widget-render-icon () gdk:pixbuf
 300   (widget widget)
 301   (stock-id string)
 302   (size icon-size)
 303   (detail string))
 304
 305 (defbinding widget-push-composite-child () nil)
 306
 307 (defbinding widget-pop-composite-child () nil)
 308
 309 (defbinding widget-queue-draw-area () nil
 310   (widget widget)
 311   (x int) (y int) (width int) (height int))
 312
 313 (defbinding widget-reset-shapes () nil
 314   (widget widget))
 315
 316 (defbinding widget-set-double-buffered () nil
 317   (widget widget)
 318   (double-buffered boolean))
 319
 320 (defbinding widget-set-redraw-on-allocate () nil
 321   (widget widget)
 322   (redraw-on-allocate boolean))
 323
 324 (defbinding widget-set-scroll-adjustments () boolean
 325   (widget widget)
 326   (hadjustment adjustment)
 327   (vadjustment adjustment))
 328
 329 (defbinding widget-mnemonic-activate () boolean
 330   (widget widget)
 331   (group-cycling boolean))
 332
 333 (defbinding widget-region-intersect () pointer ;gdk:region
 334   (widget widget)
 335   (region pointer)) ;gdk:region))
 336
 337 (defbinding widget-send-expose () int
 338   (widget widget)
 339   (event gdk:event))
 340
 341 (defbinding widget-get-accessible () atk:object
 342   (widget widget))
 343
 344 (defbinding widget-child-focus () boolean
 345   (widget widget)
 346   (direction direction-type))
 347
 348 (defbinding widget-child-notify () nil
 349   (widget widget)
 350   (child-property string))
 351
 352 (defbinding widget-freeze-child-notify () nil
 353   (widget widget))
 354
 355 (defbinding %widget-get-size-request () nil
 356   (widget widget)
 357   (width int :out)
 358   (height int :out))
 359
 360 (defun widget-get-size-request (widget)
 361   (multiple-value-bind (width height) (%widget-get-size-request widget)
 362      (values (unless (= width -1) width) (unless (= height -1) height))))
 363
 364 (defbinding widget-set-size-request (widget width height) nil
 365   (widget widget)
 366   ((or width -1) int)
 367   ((or height -1) int))
 368
 369 (defbinding widget-thaw-child-notify () nil
 370   (widget widget))
 371
 372
 373 ;;; Additional bindings and functions
 374
 375 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
 376   (widget widget))
 377
 378 (defbinding widget-get-size-allocation () nil
 379   (widget widget)
 380   (width int :out)
 381   (height int :out))
 382
 383 (defbinding get-event-widget () widget
 384   (event gdk:event))
 385
 386 (defun (setf widget-cursor) (cursor-type widget)
 387   (let ((cursor (make-instance 'cursor  :type cursor-type)))
 388     (gdk:window-set-cursor (widget-window widget) cursor)))