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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gdkevents.lisp,v 1.13 2008-01-07 16:02:23 espen Exp $
  24
  25 (in-package "GDK")
  26
  27
  28 ;;;; Metaclass for event classes
  29
  30 (eval-when (:compile-toplevel :load-toplevel :execute)
  31   (defvar *event-classes* (make-hash-table))
  32
  33   (defclass event-class (boxed-class)
  34     ((event-type :reader event-class-type :initform nil)))
  35
  36   (defmethod validate-superclass ((class event-class) (super standard-class))
  37     ;(subtypep (class-name super) 'event)
  38     t)
  39
  40   (defmethod shared-initialize ((class event-class) names &key name event-type)
  41     (declare (ignore names))
  42     (register-type-alias (or name (class-name class)) 'event)
  43     (call-next-method)
  44     (when event-type
  45       (setf (slot-value class 'event-type) (first event-type))
  46       (setf (gethash (first event-type) *event-classes*) class))))
  47
  48 (let ((reader (reader-function 'event-type)))
  49   (defun %event-class (location)
  50     (gethash (funcall reader location 0) *event-classes*)))
  51
  52 (defmethod make-proxy-instance :around ((class event-class) location
  53                                         &rest initargs)
  54   (let ((class (%event-class location)))
  55     (apply #'call-next-method class location initargs)))
  56
  57
  58 ;; The class event is the only class that actually exists in the
  59 ;; GObject class hierarchy
  60
  61 (eval-when (:compile-toplevel :load-toplevel :execute)
  62   (defclass event (boxed)
  63     ((%type
  64       :allocation :alien
  65       :type event-type)
  66      (window
  67       :allocation :alien
  68       :accessor event-window
  69       :initarg :window
  70       :type window)
  71      (send-event
  72       :allocation :alien
  73       :accessor event-send-event
  74       :initarg :send-event
  75       :type (bool 8)))
  76     (:metaclass boxed-class)))
  77
  78 (defmethod initialize-instance :after ((event event) &rest initargs)
  79   (declare (ignore initargs))
  80   (setf (slot-value event '%type) (event-class-type (class-of event))))
  81
  82 (defmethod make-proxy-instance ((class (eql (find-class 'event))) location &rest initargs)
  83   (let ((class (%event-class location)))
  84     (apply #'make-proxy-instance class location initargs)))
  85
  86
  87 (defclass timed-event (event)
  88   ((time
  89     :allocation :alien
  90     :accessor event-time
  91     :initarg :time
  92     :type (unsigned 32)))
  93   (:metaclass event-class))
  94
  95 (defclass delete-event (event)
  96   ()
  97   (:metaclass event-class)
  98   (:event-type :delete))
  99
 100
 101 (defclass destroy-event (event)
 102   ()
 103   (:metaclass event-class)
 104   (:event-type :destroy))
 105
 106 (defclass expose-event (event)
 107   ((x
 108     :allocation :alien
 109     :accessor event-x
 110     :initarg :x
 111     :type int)
 112    (y
 113     :allocation :alien
 114     :accessor event-y
 115     :initarg :y
 116     :type int)
 117    (width
 118     :allocation :alien
 119     :accessor event-width
 120     :initarg :width
 121     :type int)
 122    (height
 123     :allocation :alien
 124     :accessor event-height
 125     :initarg :height
 126     :type int)
 127    (region
 128     :allocation :alien
 129     :accessor event-region
 130     :initarg :region
 131     :type pointer)
 132    (count
 133     :allocation :alien
 134     :accessor event-count
 135     :initarg :count
 136     :type int))
 137   (:metaclass event-class)
 138   (:event-type :expose))
 139
 140 (defclass input-event (timed-event)
 141   ((x
 142     :allocation :alien
 143     :accessor event-x
 144     :initarg :x
 145     :type double-float)
 146    (y
 147     :allocation :alien
 148     :accessor event-y
 149     :initarg :y
 150     :type double-float)
 151    (axes
 152     :allocation :alien
 153     :accessor event-axes
 154     :initarg :axes
 155     :type pointer) ;double-float)
 156    (state
 157     :allocation :alien
 158     :accessor event-state
 159     :initarg :state
 160     :type modifier-type))
 161   (:metaclass event-class))
 162
 163
 164 (defclass motion-notify-event (input-event)
 165   ((is-hint
 166     :allocation :alien
 167     :accessor event-is-hint
 168     :initarg :is-hint
 169     :type (signed 16)                   ; should it be (boolean 16)?
 170     )
 171    (device
 172     :allocation :alien
 173     :offset 2
 174     :accessor event-device
 175     :initarg :device
 176     :type device)
 177    (root-x
 178     :allocation :alien
 179     :accessor event-root-x
 180     :initarg :root-x
 181     :type double-float)
 182    (root-y
 183     :allocation :alien
 184     :accessor event-root-y
 185     :initarg :root-y
 186     :type double-float))
 187   (:metaclass event-class)
 188   (:event-type :motion-notify))
 189
 190 (defclass button-event (input-event)
 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
 213 (defclass button-press-event (button-event)
 214   ()
 215   (:metaclass event-class)
 216   (:event-type :button-press))
 217
 218 (defclass 2-button-press-event (button-press-event)
 219   ()
 220   (:metaclass event-class)
 221   (:event-type :2button-press))
 222
 223 (defclass 3-button-press-event (button-press-event)
 224   ()
 225   (:metaclass event-class)
 226   (:event-type :3button-press))
 227
 228 (defclass button-release-event (button-event)
 229   ()
 230   (:metaclass event-class)
 231   (:event-type :button-release))
 232
 233
 234 (defclass key-event (timed-event)
 235   ((state
 236     :allocation :alien
 237     :accessor event-state
 238     :initarg :state
 239     :type modifier-type)
 240    (keyval
 241     :allocation :alien
 242     :accessor event-keyval
 243     :initarg :keyval
 244     :type unsigned-int)
 245    (length
 246     :allocation :alien
 247     :accessor event-length
 248     :initarg :length
 249     :type unsigned-int)
 250    (string
 251     :allocation :alien
 252     :accessor event-string
 253     :initarg :string
 254     :type string)
 255    (hardware-keycode
 256     :allocation :alien
 257     :accessor event-hardware-keycode
 258     :initarg :hardware-keycode
 259     :type (unsigned 16))
 260    (group
 261     :allocation :alien
 262     :accessor event-group
 263     :initarg :group
 264     :type (unsigned 8)))
 265   (:metaclass event-class))
 266
 267 (defclass key-press-event (key-event)
 268   ()
 269   (:metaclass event-class)
 270   (:event-type :key-press))
 271
 272 (defclass key-release-event (key-event)
 273   ()
 274   (:metaclass event-class)
 275   (:event-type :key-release))
 276
 277
 278 (defclass crossing-event (event)
 279   ((subwindow
 280     :allocation :alien
 281     :accessor event-subwindow
 282     :initarg :subwindow
 283     :type window)
 284    (time
 285     :allocation :alien
 286     :accessor event-time
 287     :initarg :time
 288     :type (unsigned 32))
 289    (x
 290     :allocation :alien
 291     :accessor event-x
 292     :initarg :x
 293     :type double-float)
 294    (y
 295     :allocation :alien
 296     :accessor event-y
 297     :initarg :y
 298     :type double-float)
 299    (root-x
 300     :allocation :alien
 301     :accessor event-root-x
 302     :initarg :root-x
 303     :type double-float)
 304    (root-y
 305     :allocation :alien
 306     :accessor event-root-y
 307     :initarg :root-y
 308     :type double-float)
 309    (mode
 310     :allocation :alien
 311     :accessor event-mode
 312     :initarg :mode
 313     :type crossing-mode)
 314    (detail
 315     :allocation :alien
 316     :accessor event-detail
 317     :initarg :detail
 318     :type notify-type)
 319    (focus
 320     :allocation :alien
 321     :accessor event-focus
 322     :initarg :focus
 323     :type boolean)
 324    (state
 325     :allocation :alien
 326     :accessor event-state
 327     :initarg :state
 328     :type unsigned-int))
 329   (:metaclass event-class))
 330
 331
 332 (defclass enter-notify-event (crossing-event)
 333   ()
 334   (:metaclass event-class)
 335   (:event-type :enter-notify))
 336
 337 (defclass leave-notify-event (crossing-event)
 338   ()
 339   (:metaclass event-class)
 340   (:event-type :leave-notify))
 341
 342 (defclass focus-change-event (event)
 343   ((in
 344     :allocation :alien
 345     :accessor event-in
 346     :initarg :in
 347     :type (bool 16)))
 348   (:metaclass event-class)
 349   (:event-type :focus-change))
 350
 351 (defclass configure-event (event)
 352   ((x
 353     :allocation :alien
 354     :accessor event-x
 355     :initarg :x
 356     :type int)
 357    (y
 358     :allocation :alien
 359     :accessor event-y
 360     :initarg :y
 361     :type int)
 362    (width
 363     :allocation :alien
 364     :accessor event-width
 365     :initarg :width
 366     :type int)
 367    (height
 368     :allocation :alien
 369     :accessor event-height
 370     :initarg :height
 371     :type int))
 372   (:metaclass event-class)
 373   (:event-type :configure))
 374
 375 (defclass map-event (event)
 376   ()
 377   (:metaclass event-class)
 378   (:event-type :map))
 379
 380 (defclass unmap-event (event)
 381   ()
 382   (:metaclass event-class)
 383   (:event-type :unmap))
 384
 385 (defclass property-notify-event (event)
 386   ()
 387   (:metaclass event-class)
 388   (:event-type :property-notify))
 389
 390 (defclass selection-clear-event (event)
 391   ()
 392   (:metaclass event-class)
 393   (:event-type :selection-clear))
 394
 395 (defclass selection-request-event (event)
 396   ()
 397   (:metaclass event-class)
 398   (:event-type :selection-request))
 399
 400 (defclass selection-notify-event (event)
 401   ()
 402   (:metaclass event-class)
 403   (:event-type :selection-notify))
 404
 405 (defclass dnd-event (event)
 406   ((context
 407     :allocation :alien
 408     :accessor event-contex
 409     :initarg :context
 410     :type drag-context)
 411    (time
 412     :allocation :alien
 413     :accessor event-time
 414     :initarg :time
 415     :type (unsigned 32))
 416    (x-root
 417     :allocation :alien
 418     :accessor event-x-root
 419     :initarg :x-root
 420     :type short)
 421    (y-root
 422     :allocation :alien
 423     :accessor event-y-root
 424     :initarg :y-root
 425     :type short))
 426   (:metaclass event-class))
 427
 428 (defclass drag-enter-event (dnd-event)
 429   ()
 430   (:metaclass event-class)
 431   (:event-type :drag-enter))
 432
 433 (defclass drag-leave-event (dnd-event)
 434   ()
 435   (:metaclass event-class)
 436   (:event-type :drag-leave))
 437
 438 (defclass drag-motion-event (dnd-event)
 439   ()
 440   (:metaclass event-class)
 441   (:event-type :drag-motion))
 442
 443 (defclass drag-status-event (dnd-event)
 444   ()
 445   (:metaclass event-class)
 446   (:event-type :drag-status))
 447
 448 (defclass drot-start-event (dnd-event)
 449   ()
 450   (:metaclass event-class)
 451   (:event-type :drop-start))
 452
 453 (defclass drop-finished-event (dnd-event)
 454   ()
 455   (:metaclass event-class)
 456   (:event-type :drop-finished))
 457
 458 (defclass client-event (event)
 459   ()
 460   (:metaclass event-class)
 461   (:event-type :client-event))
 462
 463 (defclass visibility-notify-event (event)
 464   ((state
 465     :allocation :alien
 466     :accessor event-state
 467     :initarg :state
 468     :type visibility-state))
 469   (:metaclass event-class)
 470   (:event-type :visibility-notify))
 471
 472 (defclass no-expose-event (event)
 473   ()
 474   (:metaclass event-class)
 475   (:event-type :no-expose))
 476
 477 (defclass scroll-event (timed-event)
 478   ((x
 479     :allocation :alien
 480     :accessor event-x
 481     :initarg :x
 482     :type double-float)
 483    (y
 484     :allocation :alien
 485     :accessor event-y
 486     :initarg :y
 487     :type double-float)
 488    (state
 489     :allocation :alien
 490     :accessor event-state
 491     :initarg :state
 492     :type modifier-type)
 493    (direction
 494     :allocation :alien
 495     :accessor event-direction
 496     :initarg :direction
 497     :type scroll-direction)
 498    (root-x
 499     :allocation :alien
 500     :accessor event-root-x
 501     :initarg :root-x
 502     :type double-float)
 503    (root-y
 504     :allocation :alien
 505     :accessor event-root-y
 506     :initarg :root-y
 507     :type double-float))
 508   (:metaclass event-class)
 509   (:event-type :scroll))
 510
 511 (defclass setting-event (event)
 512   ((action
 513     :allocation :alien
 514     :accessor event-action
 515     :initarg :action
 516     :type setting-action)
 517    (name
 518     :allocation :alien
 519     :accessor event-name
 520     :initarg :name
 521     :type string))
 522   (:metaclass event-class)
 523   (:event-type :setting))
 524
 525 (defclass proximity-event (timed-event)
 526   ((device
 527     :allocation :alien
 528     :accessor event-device
 529     :initarg :device
 530     :type device))
 531   (:metaclass event-class))
 532
 533 (defclass proximity-in-event (proximity-event)
 534   ()
 535   (:metaclass event-class)
 536   (:event-type :proximity-in))
 537
 538 (defclass proximity-out-event (proximity-event)
 539   ()
 540   (:metaclass event-class)
 541   (:event-type :proximity-out))
 542
 543 (defclass window-state-event (event)
 544   ((change-mask
 545     :allocation :alien
 546     :accessor event-change-mask
 547     :initarg :change-mask
 548     :type window-state)
 549    (new-window-state
 550     :allocation :alien
 551     :accessor event-new-window-state
 552     :initarg :new-window-state
 553     :type window-state))
 554   (:metaclass event-class)
 555   (:event-type :window-state))
 556
 557 (defclass owner-change-event (event)
 558   ()
 559   (:metaclass event-class)
 560   (:event-type :owner-change))
 561