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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.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.4 2001-05-29 15:58:24 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  23 (defmethod initialize-instance ((widget widget) &rest initargs &key parent)
  24   (declare (ignore initargs))
  25   (call-next-method)
  26   (cond
  27    ((consp parent)
  28     (with-slots ((container parent) child-slots) widget
  29       (setf
  30        container (car parent)
  31        child-slots
  32        (apply
  33         #'make-instance
  34         (slot-value (class-of container) 'child-class)
  35         :parent container :child widget (cdr parent)))))
  36    (parent
  37     (setf (slot-value widget 'parent) parent))))
  38
  39
  40 (defmethod slot-unbound ((class gobject) (object widget) slot)
  41   (cond
  42    ((and (eq slot 'child-slots) (slot-value object 'parent))
  43     (with-slots (parent child-slots) object
  44       (setf
  45        child-slots
  46        (make-instance
  47         (gethash (class-of parent) *container-to-child-class-mappings*)
  48         :parent parent :child object))))
  49    (t (call-next-method))))
  50
  51
  52 (defun child-slot-value (widget slot)
  53   (slot-value (widget-child-slots widget) slot))
  54
  55 (defun (setf child-slot-value) (value widget slot)
  56   (setf (slot-value (widget-child-slots widget) slot) value))
  57
  58 (defmacro with-child-slots (slots widget &body body)
  59   `(with-slots ,slots (widget-child-slots ,widget)
  60      ,@body))
  61
  62 (defmacro widget-destroyed (place)
  63   `(setf ,place nil))
  64
  65 (defbinding widget-destroy () nil
  66   (widget widget))
  67
  68 (defbinding widget-unparent () nil
  69   (widget widget))
  70
  71 (defbinding widget-show () nil
  72   (widget widget))
  73
  74 (defbinding widget-show-now () nil
  75   (widget widget))
  76
  77 (defbinding widget-hide () nil
  78   (widget widget))
  79
  80 (defbinding widget-show-all () nil
  81   (widget widget))
  82
  83 (defbinding widget-hide-all () nil
  84   (widget widget))
  85
  86 (defbinding widget-map () nil
  87   (widget widget))
  88
  89 (defbinding widget-unmap () nil
  90   (widget widget))
  91
  92 (defbinding widget-realize () nil
  93   (widget widget))
  94
  95 (defbinding widget-unrealize () nil
  96   (widget widget))
  97
  98 (defbinding widget-add-accelerator
  99     (widget signal accel-group key modifiers flags) nil
 100   (widget widget)
 101   ((name-to-string signal) string)
 102   (accel-group accel-group)
 103   ((gdk:keyval-from-name key) unsigned-int)
 104   (modifiers gdk:modifier-type)
 105   (flags accel-flags))
 106
 107 (defbinding widget-remove-accelerator
 108     (widget accel-group key modifiers) nil
 109   (widget widget)
 110   (accel-group accel-group)
 111   ((gdk:keyval-from-name key) unsigned-int)
 112   (modifiers gdk:modifier-type))
 113
 114 (defbinding widget-accelerator-signal
 115     (widget accel-group key modifiers) unsigned-int
 116   (widget widget)
 117   (accel-group accel-group)
 118   ((gdk:keyval-from-name key) unsigned-int)
 119   (modifiers gdk:modifier-type))
 120
 121 (defbinding widget-lock-accelerators () nil
 122   (widget widget))
 123
 124 (defbinding widget-unlock-accelerators () nil
 125   (widget widget))
 126
 127 (defbinding (widget-accelerators-locked-p "gtk_widget_accelerators_locked")
 128     () boolean
 129   (widget widget))
 130
 131 (defbinding widget-event () int
 132   (widget widget)
 133   (event gdk:event))
 134
 135 (defbinding get-event-widget () widget
 136   (event gdk:event))
 137
 138 (defbinding widget-activate () boolean
 139   (widget widget))
 140
 141 (defbinding widget-set-scroll-adjustments () boolean
 142   (widget widget)
 143   (hadjustment adjustment)
 144   (vadjustment adjustment))
 145
 146 (defbinding widget-reparent () nil
 147   (widget widget)
 148   (new-parent widget))
 149
 150 ; (defbinding widget-popup () nil
 151 ;   (widget widget)
 152 ;   (x int)
 153 ;   (y int))
 154
 155 (defbinding widget-grab-focus () nil
 156   (widget widget))
 157
 158 (defbinding widget-grab-default () nil
 159   (widget widget))
 160
 161 (defbinding grab-add () nil
 162   (widget widget))
 163
 164 (defbinding grab-get-current () widget)
 165
 166 (defbinding grab-remove () nil
 167   (widget widget))
 168
 169 (defbinding widget-allocation () nil
 170   (widget widget)
 171   (width int :out)
 172   (height int :out))
 173
 174
 175 (defbinding widget-set-uposition (widget &key (x t) (y t)) nil
 176   (widget widget)
 177   ((case x
 178      ((t) -2)
 179      ((nil) -1)
 180      (otherwise x)) int)
 181   ((case y
 182      ((t) -2)
 183      ((nil) -1)
 184      (otherwise y)) int))
 185
 186 (defbinding widget-add-events () nil
 187   (widget widget)
 188   (events gdk:event-mask))
 189
 190 (defbinding (widget-toplevel "gtk_widget_get_toplevel") () widget
 191   (widget widget))
 192
 193 (defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget
 194   (widget widget)
 195   ((find-type-number type) type-number))
 196
 197 ; (defbinding ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
 198 ;   (widget widget))
 199
 200 ; (defbinding ("gtk_widget_get_visual" widget-visual) () gdk:visual
 201 ;   (widget widget))
 202
 203 (defbinding (widget-pointer "gtk_widget_get_pointer") () nil
 204   (widget widget)
 205   (x int :out)
 206   (y int :out))
 207
 208 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
 209   (widget widget)
 210   (ancestor widget))
 211
 212 (defbinding widget-set-rc-style () nil
 213   (widget widget))
 214
 215 (defbinding widget-ensure-style () nil
 216   (widget widget))
 217
 218 (defbinding widget-restore-default-style () nil
 219   (widget widget))
 220
 221 (defbinding widget-reset-rc-styles () nil
 222   (widget widget))
 223
 224 (defun (setf widget-cursor) (cursor-type widget)
 225   (let ((cursor (gdk:cursor-new cursor-type))
 226         (window (widget-window widget)))
 227     (gdk:window-set-cursor window cursor)
 228     ;(gdk:cursor-destroy cursor)
 229     ))
 230
 231 ;; Push/pop pairs, to change default values upon a widget's creation.
 232 ;; This will override the values that got set by the
 233 ;; widget-set-default-* functions.
 234
 235 (defbinding widget-push-style () nil
 236   (style style))
 237
 238 (defbinding widget-push-colormap () nil
 239   (colormap gdk:colormap))
 240
 241 ; (defbinding widget-push-visual () nil
 242 ;   (visual gdk:visual))
 243
 244 (defbinding widget-push-composite-child () nil)
 245
 246 (defbinding widget-pop-style () nil)
 247
 248 (defbinding widget-pop-colormap () nil)
 249
 250 ;(defbinding widget-pop-visual () nil)
 251
 252 (defbinding widget-pop-composite-child () nil)
 253
 254
 255 ;; Set certain default values to be used at widget creation time.
 256
 257 (defbinding widget-set-default-style () nil
 258   (style style))
 259
 260 (defbinding widget-set-default-colormap () nil
 261   (colormap gdk:colormap))
 262
 263 ; (defbinding widget-set-default-visual () nil
 264 ;   (visual gdk:visual))
 265
 266 (defbinding widget-get-default-style () style)
 267
 268 (defbinding widget-get-default-colormap () gdk:colormap)
 269
 270 (defbinding widget-get-default-visual () gdk:visual)
 271
 272 (defbinding widget-shape-combine-mask () nil
 273   (widget widget)
 274   (shape-mask gdk:bitmap)
 275   (x-offset int)
 276   (y-offset int))
 277
 278 ;; defined in gtkglue.c
 279 (defbinding widget-mapped-p () boolean
 280   (widget widget))
 281