mdw@git.distorted.org.uk Git - clg/blob - gtk/gtkwidget.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
   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.2 2000-08-16 22:16:44 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (defclass widget (object)
  25     ((child-slots
  26       :allocation :instance
  27       :accessor widget-child-slots
  28       :type container-child)
  29      (name
  30       :allocation :arg
  31       :accessor widget-name
  32       :initarg :name
  33       :type string)
  34      (parent
  35       :allocation :arg
  36       :accessor widget-parent
  37 ;     :initarg :parent
  38       :type container)
  39      (x
  40       :allocation :arg
  41       :accessor widget-x-position
  42       :initarg :x
  43       :type int)
  44      (y
  45       :allocation :arg
  46       :accessor widget-y-position
  47       :initarg :y
  48       :type int)
  49      (width
  50       :allocation :arg
  51       :accessor widget-width
  52       :initarg :width
  53       :type int)
  54      (height
  55       :allocation :arg
  56       :accessor widget-height
  57       :initarg :height
  58       :type int)
  59      (visible
  60       :allocation :arg
  61       :accessor widget-visible-p
  62       :initarg :visible
  63       :type boolean)
  64      (sensitive
  65       :allocation :arg
  66       :accessor widget-sensitive-p
  67       :initarg :sensitive
  68       :type boolean)
  69      (app-paintable
  70       :allocation :arg
  71       :reader widget-app-paintable-p
  72 ;     :access :read-only
  73       :type boolean)
  74      (can-focus
  75       :allocation :arg
  76       :accessor widget-can-focus-p
  77       :initarg :can-focus
  78       :type boolean)
  79      (has-focus
  80       :allocation :arg
  81       :accessor widget-has-focus-p
  82       :initarg :has-focus
  83       :type boolean)
  84      (can-default
  85       :allocation :arg
  86       :accessor widget-can-default-p
  87       :initarg :can-default
  88       :type boolean)
  89      (has-default
  90       :allocation :arg
  91       :accessor widget-has-default-p
  92       :initarg :has-default
  93       :type boolean)
  94      (receives-default
  95       :allocation :arg
  96       :accessor widget-receives-default-p
  97       :initarg :receives-default
  98       :type boolean)
  99      (composite-child
 100       :allocation :arg
 101       :accessor widget-composite-child-p
 102       :initarg :composite-child
 103       :type boolean)
 104 ;    (style
 105 ;     :allocation :arg
 106 ;     :accessor widget-style
 107 ;     :initarg :style
 108 ;     :type style)
 109      (events
 110       :allocation :arg
 111       :accessor widget-events
 112       :initarg :events
 113       :type gdk:event-mask)
 114      (extension-events
 115       :allocation :arg
 116       :accessor widget-extension-events
 117       :initarg :extpension-events
 118       :type gdk:event-mask)
 119      (state
 120       :allocation :virtual
 121       :location ("gtk_widget_get_state" "gtk_widget_set_state")
 122       :accessor widget-state
 123       :initarg :state
 124       :type state-type)
 125      (window
 126       :allocation :virtual
 127       :location "gtk_widget_get_window"
 128       :reader widget-window
 129       :type gdk:window)
 130      (colormap
 131       :allocation :virtual
 132       :location "gtk_widget_get_colormap"
 133       :reader widget-colormap
 134       :type gdk:colormap)
 135      (visual
 136       :allocation :virtual
 137       :location "gtk_widget_get_visual"
 138       :reader widget-visual
 139       :type gdk:visual))
 140     (:metaclass object-class)
 141     (:alien-name "GtkWidget")))
 142
 143
 144 (defmethod initialize-instance ((widget widget) &rest initargs &key parent)
 145   (declare (ignore initargs))
 146   (cond
 147    ((consp parent)
 148     (with-slots ((container parent) child-slots) widget
 149       (setf
 150        container (car parent)
 151        child-slots
 152        (apply
 153         #'make-instance
 154         (slot-value (class-of container) 'child-class)
 155         :parent container :child widget (cdr parent)))))
 156    (parent
 157     (setf (slot-value widget 'parent) parent)))
 158     (call-next-method))
 159
 160
 161 (defmethod slot-unbound ((class object-class) (object widget) slot)
 162   (cond
 163    ((and (eq slot 'child-slots) (slot-value object 'parent))
 164     (with-slots (parent child-slots) object
 165       (setf
 166        child-slots
 167        (make-instance
 168         (slot-value (class-of parent) 'child-class)
 169         :parent parent :child object))))
 170    (t (call-next-method))))
 171
 172
 173 (defun child-slot-value (widget slot)
 174   (slot-value (widget-child-slots widget) slot))
 175
 176 (defun (setf child-slot-value) (value widget slot)
 177   (setf (slot-value (widget-child-slots widget) slot) value))
 178
 179 (defmacro with-child-slots (slots widget &body body)
 180   `(with-slots ,slots (widget-child-slots ,widget)
 181      ,@body))
 182
 183 (defmacro widget-destroyed (place)
 184   `(setf ,place nil))
 185
 186 (define-foreign widget-destroy () nil
 187   (widget widget))
 188
 189 (define-foreign widget-unparent () nil
 190   (widget widget))
 191
 192 (define-foreign widget-show () nil
 193   (widget widget))
 194
 195 (define-foreign widget-show-now () nil
 196   (widget widget))
 197
 198 (define-foreign widget-hide () nil
 199   (widget widget))
 200
 201 (define-foreign widget-show-all () nil
 202   (widget widget))
 203
 204 (define-foreign widget-hide-all () nil
 205   (widget widget))
 206
 207 (define-foreign widget-map () nil
 208   (widget widget))
 209
 210 (define-foreign widget-unmap () nil
 211   (widget widget))
 212
 213 (define-foreign widget-realize () nil
 214   (widget widget))
 215
 216 (define-foreign widget-unrealize () nil
 217   (widget widget))
 218
 219 (define-foreign widget-add-accelerator
 220     (widget signal accel-group key modifiers flags) nil
 221   (widget widget)
 222   ((name-to-string signal) string)
 223   (accel-group accel-group)
 224   ((gdk:keyval-from-name key) unsigned-int)
 225   (modifiers gdk:modifier-type)
 226   (flags accel-flags))
 227
 228 (define-foreign widget-remove-accelerator
 229     (widget accel-group key modifiers) nil
 230   (widget widget)
 231   (accel-group accel-group)
 232   ((gdk:keyval-from-name key) unsigned-int)
 233   (modifiers gdk:modifier-type))
 234
 235 (define-foreign widget-accelerator-signal
 236     (widget accel-group key modifiers) unsigned-int
 237   (widget widget)
 238   (accel-group accel-group)
 239   ((gdk:keyval-from-name key) unsigned-int)
 240   (modifiers gdk:modifier-type))
 241
 242 (define-foreign widget-lock-accelerators () nil
 243   (widget widget))
 244
 245 (define-foreign widget-unlock-accelerators () nil
 246   (widget widget))
 247
 248 (define-foreign
 249     ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean
 250   (widget widget))
 251
 252 (define-foreign widget-event () int
 253   (widget widget)
 254   (event gdk:event))
 255
 256 (define-foreign get-event-widget () widget
 257   (event gdk:event))
 258
 259 (define-foreign widget-activate () boolean
 260   (widget widget))
 261
 262 (define-foreign widget-set-scroll-adjustments () boolean
 263   (widget widget)
 264   (hadjustment adjustment)
 265   (vadjustment adjustment))
 266
 267 (define-foreign widget-reparent () nil
 268   (widget widget)
 269   (new-parent widget))
 270
 271 (define-foreign widget-popup () nil
 272   (widget widget)
 273   (x int)
 274   (y int))
 275
 276 (define-foreign widget-grab-focus () nil
 277   (widget widget))
 278
 279 (define-foreign widget-grab-default () nil
 280   (widget widget))
 281
 282 (define-foreign grab-add () nil
 283   (widget widget))
 284
 285 (define-foreign grab-get-current () widget)
 286
 287 (define-foreign grab-remove () nil
 288   (widget widget))
 289
 290 (define-foreign widget-allocation () nil
 291   (widget widget)
 292   (width int :out)
 293   (height int :out))
 294
 295
 296 (define-foreign widget-set-uposition (widget &key (x t) (y t)) nil
 297   (widget widget)
 298   ((case x
 299      ((t) -2)
 300      ((nil) -1)
 301      (otherwise x)) int)
 302   ((case y
 303      ((t) -2)
 304      ((nil) -1)
 305      (otherwise y)) int))
 306
 307 (define-foreign widget-add-events () nil
 308   (widget widget)
 309   (events gdk:event-mask))
 310
 311 (define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget
 312   (widget widget))
 313
 314 (define-foreign ("gtk_widget_get_ancestor"
 315                   widget-ancestor) (widget type) widget
 316   (widget widget)
 317   ((find-type-number type) type-number))
 318
 319 ; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
 320 ;   (widget widget))
 321
 322 ; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual
 323 ;   (widget widget))
 324
 325 (define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil
 326   (widget widget)
 327   (x int :out)
 328   (y int :out))
 329
 330 (define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean
 331   (widget widget)
 332   (ancestor widget))
 333
 334 (define-foreign widget-set-rc-style () nil
 335   (widget widget))
 336
 337 (define-foreign widget-ensure-style () nil
 338   (widget widget))
 339
 340 (define-foreign widget-restore-default-style () nil
 341   (widget widget))
 342
 343 (define-foreign widget-reset-rc-styles () nil
 344   (widget widget))
 345
 346 (defun (setf widget-cursor) (cursor-type widget)
 347   (let ((cursor (gdk:cursor-new cursor-type))
 348         (window (widget-window widget)))
 349     (gdk:window-set-cursor window cursor)
 350     ;(gdk:cursor-destroy cursor)
 351     ))
 352
 353 ;; Push/pop pairs, to change default values upon a widget's creation.
 354 ;; This will override the values that got set by the
 355 ;; widget-set-default-* functions.
 356
 357 (define-foreign widget-push-style () nil
 358   (style style))
 359
 360 (define-foreign widget-push-colormap () nil
 361   (colormap gdk:colormap))
 362
 363 ; (define-foreign widget-push-visual () nil
 364 ;   (visual gdk:visual))
 365
 366 (define-foreign widget-push-composite-child () nil)
 367
 368 (define-foreign widget-pop-style () nil)
 369
 370 (define-foreign widget-pop-colormap () nil)
 371
 372 ;(define-foreign widget-pop-visual () nil)
 373
 374 (define-foreign widget-pop-composite-child () nil)
 375
 376
 377 ;; Set certain default values to be used at widget creation time.
 378
 379 (define-foreign widget-set-default-style () nil
 380   (style style))
 381
 382 (define-foreign widget-set-default-colormap () nil
 383   (colormap gdk:colormap))
 384
 385 ; (define-foreign widget-set-default-visual () nil
 386 ;   (visual gdk:visual))
 387
 388 (define-foreign widget-get-default-style () style)
 389
 390 (define-foreign widget-get-default-colormap () gdk:colormap)
 391
 392 (define-foreign widget-get-default-visual () gdk:visual)
 393
 394 (define-foreign widget-shape-combine-mask () nil
 395   (widget widget)
 396   (shape-mask gdk:bitmap)
 397   (x-offset int)
 398   (y-offset int))
 399
 400 ;; defined in gtkglue.c
 401 (define-foreign widget-mapped-p () boolean
 402   (widget widget))
 403