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