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