chiark - git - mdw - clg/blob - gdk/gdkevents.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-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: gdkevents.lisp,v 1.5 2004-11-06 21:39:58 espen Exp $
  19
  20 (in-package "GDK")
  21
  22
  23 (defvar *event-classes* (make-hash-table))
  24
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (defclass event (boxed)
  27     ((%type
  28       :allocation :alien
  29       :type event-type)
  30      (window
  31       :allocation :alien
  32       :accessor event-window
  33       :initarg :window
  34       :type window)
  35      (send-event
  36       :allocation :alien
  37       :accessor event-send-event
  38       :initarg :send-event
  39       :type (boolean 8))
  40      (%align :allocation :alien :offset 2 :type (unsigned 8)))
  41     (:metaclass boxed-class)))
  42
  43
  44 (defmethod initialize-instance ((event event) &rest initargs)
  45   (declare (ignore initargs))
  46   (call-next-method)
  47   (setf (slot-value event '%type) (event-class-type (class-of event))))
  48
  49
  50 ;;;; Metaclass for event classes
  51
  52 (eval-when (:compile-toplevel :load-toplevel :execute)
  53   (defclass event-class (boxed-class)
  54     ((event-type :reader event-class-type)))
  55
  56   (defmethod validate-superclass ((class event-class) (super standard-class))
  57     (subtypep (class-name super) 'event)))
  58
  59
  60 (defmethod shared-initialize ((class event-class) names &key name type)
  61   (call-next-method)
  62   (setf (slot-value class 'event-type) (first type))
  63   (setf (gethash (first type) *event-classes*) class)
  64   (let ((class-name (or name (class-name class))))
  65     (register-type class-name 'event)))
  66
  67 (let ((reader (reader-function 'event-type)))
  68   (defun %event-class (location)
  69     (gethash (funcall reader location 0) *event-classes*)))
  70
  71 (defmethod ensure-proxy-instance ((class event-class) location)
  72   (declare (ignore class))
  73   (let ((class (%event-class location)))
  74     (make-instance class :location location)))
  75
  76
  77 ;;;;
  78
  79 (defclass timed-event (event)
  80   ((time
  81     :allocation :alien
  82     :accessor event-time
  83     :initarg :time
  84     :type (unsigned 32)))
  85   (:metaclass event-class))
  86
  87 (defclass delete-event (event)
  88   ()
  89   (:metaclass event-class)
  90   (:type :delete))
  91
  92
  93 (defclass destroy-event (event)
  94   ()
  95   (:metaclass event-class)
  96   (:type :destroy))
  97
  98 (defclass expose-event (event)
  99   ((x
 100     :allocation :alien
 101     :accessor event-x
 102     :initarg :x
 103     :type int)
 104    (y
 105     :allocation :alien
 106     :accessor event-y
 107     :initarg :y
 108     :type int)
 109    (width
 110     :allocation :alien
 111     :accessor event-width
 112     :initarg :width
 113     :type int)
 114    (height
 115     :allocation :alien
 116     :accessor event-height
 117     :initarg :height
 118     :type int)
 119    (count
 120     :allocation :alien
 121     :accessor event-count
 122     :initarg :count
 123     :type int))
 124   (:metaclass event-class)
 125   (:type :expose))
 126
 127 (defclass motion-notify-event (timed-event)
 128   ((x
 129     :allocation :alien
 130     :accessor event-x
 131     :initarg :x
 132     :type double-float)
 133    (y
 134     :allocation :alien
 135     :accessor event-y
 136     :initarg :y
 137     :type double-float)
 138    (state
 139     :allocation :alien
 140     :offset #.(size-of 'pointer)
 141     :accessor event-state
 142     :initarg :state
 143     :type unsigned-int)
 144    (is-hint
 145     :allocation :alien
 146     :accessor event-is-hint
 147     :initarg :is-hint
 148     :type (signed 16)                   ; should it be (boolean 16)?
 149     )
 150    (device
 151     :allocation :alien
 152     :offset 2
 153     :accessor event-device
 154     :initarg :device
 155     :type device)
 156    (root-x
 157     :allocation :alien
 158     :accessor event-root-x
 159     :initarg :root-x
 160     :type double-float)
 161    (root-y
 162     :allocation :alien
 163     :accessor event-root-y
 164     :initarg :root-y
 165     :type double-float))
 166   (:metaclass event-class)
 167   (:type :motion-notify))
 168
 169 (defclass button-press-event (timed-event)
 170   ((x
 171     :allocation :alien
 172     :accessor event-x
 173     :initarg :x
 174     :type double-float)
 175    (y
 176     :allocation :alien
 177     :accessor event-y
 178     :initarg :y
 179     :type double-float)
 180    (state
 181     :allocation :alien
 182     :offset #.(size-of 'pointer)
 183     :accessor event-state
 184     :initarg :state
 185     :type modifier-type)
 186    (button
 187     :allocation :alien
 188     :accessor event-button
 189     :initarg :button
 190     :type unsigned-int)
 191    (device
 192     :allocation :alien
 193     :accessor event-device
 194     :initarg :device
 195     :type device)
 196    (root-x
 197     :allocation :alien
 198     :accessor event-root-x
 199     :initarg :root-x
 200     :type double-float)
 201    (root-y
 202     :allocation :alien
 203     :accessor event-root-y
 204     :initarg :root-y
 205     :type double-float))
 206   (:metaclass event-class)
 207   (:type :button-press))
 208
 209 (defclass 2-button-press-event (button-press-event)
 210   ()
 211   (:metaclass event-class)
 212   (:type :2button-press))
 213
 214 (defclass 3-button-press-event (button-press-event)
 215   ()
 216   (:metaclass event-class)
 217   (:type :3button-press))
 218
 219 (defclass button-release-event (button-press-event)
 220   ()
 221   (:metaclass event-class)
 222   (:type :button-release))
 223
 224 (defclass key-press-event (event)
 225   ()
 226   (:metaclass event-class)
 227   (:type :key-press))
 228
 229 (defclass key-release-event (event)
 230   ()
 231   (:metaclass event-class)
 232   (:type :key-release))
 233
 234 (defclass enter-notify-event (event)
 235   ()
 236   (:metaclass event-class)
 237   (:type :enter-notify))
 238
 239 (defclass leave-notify-event (event)
 240   ()
 241   (:metaclass event-class)
 242   (:type :leave-notify))
 243
 244 (defclass focus-change-event (event)
 245   ()
 246   (:metaclass event-class)
 247   (:type :focus-change))
 248
 249 (defclass configure-event (event)
 250   ((x
 251     :allocation :alien
 252     :accessor event-x
 253     :initarg :x
 254     :type int)
 255    (y
 256     :allocation :alien
 257     :accessor event-y
 258     :initarg :y
 259     :type int)
 260    (width
 261     :allocation :alien
 262     :accessor event-width
 263     :initarg :width
 264     :type int)
 265    (height
 266     :allocation :alien
 267     :accessor event-height
 268     :initarg :height
 269     :type int))
 270   (:metaclass event-class)
 271   (:type :configure))
 272
 273 (defclass map-event (event)
 274   ()
 275   (:metaclass event-class)
 276   (:type :map))
 277
 278 (defclass unmap-event (event)
 279   ()
 280   (:metaclass event-class)
 281   (:type :unmap))
 282
 283 (defclass property-notify-event (event)
 284   ()
 285   (:metaclass event-class)
 286   (:type :property-notify))
 287
 288 (defclass selection-clear-event (event)
 289   ()
 290   (:metaclass event-class)
 291   (:type :selection-clear))
 292
 293 (defclass selection-request-event (event)
 294   ()
 295   (:metaclass event-class)
 296   (:type :selection-request))
 297
 298 (defclass selection-notify-event (event)
 299   ()
 300   (:metaclass event-class)
 301   (:type :selection-notify))
 302
 303 (defclass drag-enter-event (event)
 304   ()
 305   (:metaclass event-class)
 306   (:type :drag-enter))
 307
 308 (defclass drag-leave-event (event)
 309   ()
 310   (:metaclass event-class)
 311   (:type :drag-leave))
 312
 313 (defclass drag-motion-event (event)
 314   ()
 315   (:metaclass event-class)
 316   (:type :drag-motion))
 317
 318 (defclass drag-status-event (event)
 319   ()
 320   (:metaclass event-class)
 321   (:type :drag-status))
 322
 323 (defclass drag-start-event (event)
 324   ()
 325   (:metaclass event-class)
 326   (:type :drag-start))
 327
 328 (defclass drag-finished-event (event)
 329   ()
 330   (:metaclass event-class)
 331   (:type :drag-finished))
 332
 333 (defclass client-event (event)
 334   ()
 335   (:metaclass event-class)
 336   ;(:type :client-event)
 337   )
 338
 339 (defclass visibility-notify-event (event)
 340   ((state
 341     :allocation :alien
 342     :accessor event-state
 343     :initarg :state
 344     :type visibility-state))
 345   (:metaclass event-class)
 346   (:type :visibility-notify))
 347
 348 (defclass no-expose-event (event)
 349   ()
 350   (:metaclass event-class)
 351   (:type :no-expose))
 352
 353 (defclass scroll-event (timed-event)
 354   ()
 355   (:metaclass event-class)
 356   (:type :scroll))
 357
 358 (defclass setting-event (timed-event)
 359   ()
 360   (:metaclass event-class)
 361   (:type :setting))