chiark - git - mdw - 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.1 2000-08-14 16:45:02 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 widget-activate () boolean
 257   (widget widget))
 258
 259 (define-foreign widget-set-scroll-adjustments () boolean
 260   (widget widget)
 261   (hadjustment adjustment)
 262   (vadjustment adjustment))
 263
 264 (define-foreign widget-reparent () nil
 265   (widget widget)
 266   (new-parent widget))
 267
 268 (define-foreign widget-popup () nil
 269   (widget widget)
 270   (x int)
 271   (y int))
 272
 273 (define-foreign widget-grab-focus () nil
 274   (widget widget))
 275
 276 (define-foreign widget-grab-default () nil
 277   (widget widget))
 278
 279 ;; cl-gtk.c
 280 (define-foreign widget-allocation () nil
 281   (widget widget)
 282   (width int :out)
 283   (height int :out))
 284
 285
 286 (define-foreign widget-set-uposition (widget &key (x t) (y t)) nil
 287   (widget widget)
 288   ((case x
 289      ((t) -2)
 290      ((nil) -1)
 291      (otherwise x)) int)
 292   ((case y
 293      ((t) -2)
 294      ((nil) -1)
 295      (otherwise y)) int))
 296
 297 (define-foreign widget-add-events () nil
 298   (widget widget)
 299   (events gdk:event-mask))
 300
 301 (define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget
 302   (widget widget))
 303
 304 (define-foreign ("gtk_widget_get_ancestor"
 305                   widget-ancestor) (widget type) widget
 306   (widget widget)
 307   ((find-type-number type) type-number))
 308
 309 ; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
 310 ;   (widget widget))
 311
 312 ; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual
 313 ;   (widget widget))
 314
 315 (define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil
 316   (widget widget)
 317   (x int :out)
 318   (y int :out))
 319
 320 (define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean
 321   (widget widget)
 322   (ancestor widget))
 323
 324 (define-foreign widget-set-rc-style () nil
 325   (widget widget))
 326
 327 (define-foreign widget-ensure-style () nil
 328   (widget widget))
 329
 330 (define-foreign widget-restore-default-style () nil
 331   (widget widget))
 332
 333 (define-foreign widget-reset-rc-styles () nil
 334   (widget widget))
 335
 336 (defun (setf widget-cursor) (cursor-type widget)
 337   (let ((cursor (gdk:cursor-new cursor-type))
 338         (window (widget-window widget)))
 339     (gdk:window-set-cursor window cursor)
 340     ;(gdk:cursor-destroy cursor)
 341     ))
 342
 343 ;; Push/pop pairs, to change default values upon a widget's creation.
 344 ;; This will override the values that got set by the
 345 ;; widget-set-default-* functions.
 346
 347 (define-foreign widget-push-style () nil
 348   (style style))
 349
 350 (define-foreign widget-push-colormap () nil
 351   (colormap gdk:colormap))
 352
 353 ; (define-foreign widget-push-visual () nil
 354 ;   (visual gdk:visual))
 355
 356 (define-foreign widget-push-composite-child () nil)
 357
 358 (define-foreign widget-pop-style () nil)
 359
 360 (define-foreign widget-pop-colormap () nil)
 361
 362 ;(define-foreign widget-pop-visual () nil)
 363
 364 (define-foreign widget-pop-composite-child () nil)
 365
 366
 367 ;; Set certain default values to be used at widget creation time.
 368
 369 (define-foreign widget-set-default-style () nil
 370   (style style))
 371
 372 (define-foreign widget-set-default-colormap () nil
 373   (colormap gdk:colormap))
 374
 375 ; (define-foreign widget-set-default-visual () nil
 376 ;   (visual gdk:visual))
 377
 378 (define-foreign widget-get-default-style () style)
 379
 380 (define-foreign widget-get-default-colormap () gdk:colormap)
 381
 382 (define-foreign widget-get-default-visual () gdk:visual)
 383
 384 (define-foreign widget-shape-combine-mask () nil
 385   (widget widget)
 386   (shape-mask gdk:bitmap)
 387   (x-offset int)
 388   (y-offset int))
 389
 390 ;; cl-gtk.c
 391 (define-foreign widget-mapped-p () boolean
 392   (widget widget))
 393