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