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.12 2006-04-26 09:20:20 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 ((event event) &rest initargs)
  79   (declare (ignore initargs))
  80   (call-next-method)
  81   (setf (slot-value event '%type) (event-class-type (class-of event))))
  82
  83 (defmethod make-proxy-instance :around ((class (eql (find-class 'event))) location &rest initargs)
  84   (let ((class (%event-class location)))
  85     (apply #'call-next-method class location initargs)))
  86
  87
  88 (defclass timed-event (event)
  89   ((time
  90     :allocation :alien
  91     :accessor event-time
  92     :initarg :time
  93     :type (unsigned 32)))
  94   (:metaclass event-class))
  95
  96 (defclass delete-event (event)
  97   ()
  98   (:metaclass event-class)
  99   (:event-type :delete))
 100
 101
 102 (defclass destroy-event (event)
 103   ()
 104   (:metaclass event-class)
 105   (:event-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    (region
 129     :allocation :alien
 130     :accessor event-region
 131     :initarg :region
 132     :type pointer)
 133    (count
 134     :allocation :alien
 135     :accessor event-count
 136     :initarg :count
 137     :type int))
 138   (:metaclass event-class)
 139   (:event-type :expose))
 140
 141 (defclass input-event (timed-event)
 142   ((x
 143     :allocation :alien
 144     :accessor event-x
 145     :initarg :x
 146     :type double-float)
 147    (y
 148     :allocation :alien
 149     :accessor event-y
 150     :initarg :y
 151     :type double-float)
 152    (axes
 153     :allocation :alien
 154     :accessor event-axes
 155     :initarg :axes
 156     :type pointer) ;double-float)
 157    (state
 158     :allocation :alien
 159     :accessor event-state
 160     :initarg :state
 161     :type modifier-type))
 162   (:metaclass event-class))
 163
 164
 165 (defclass motion-notify-event (input-event)
 166   ((is-hint
 167     :allocation :alien
 168     :accessor event-is-hint
 169     :initarg :is-hint
 170     :type (signed 16)                   ; should it be (boolean 16)?
 171     )
 172    (device
 173     :allocation :alien
 174     :offset 2
 175     :accessor event-device
 176     :initarg :device
 177     :type device)
 178    (root-x
 179     :allocation :alien
 180     :accessor event-root-x
 181     :initarg :root-x
 182     :type double-float)
 183    (root-y
 184     :allocation :alien
 185     :accessor event-root-y
 186     :initarg :root-y
 187     :type double-float))
 188   (:metaclass event-class)
 189   (:event-type :motion-notify))
 190
 191 (defclass button-event (input-event)
 192   ((button
 193     :allocation :alien
 194     :accessor event-button
 195     :initarg :button
 196     :type unsigned-int)
 197    (device
 198     :allocation :alien
 199     :accessor event-device
 200     :initarg :device
 201     :type device)
 202    (root-x
 203     :allocation :alien
 204     :accessor event-root-x
 205     :initarg :root-x
 206     :type double-float)
 207    (root-y
 208     :allocation :alien
 209     :accessor event-root-y
 210     :initarg :root-y
 211     :type double-float))
 212   (:metaclass event-class))
 213
 214 (defclass button-press-event (button-event)
 215   ()
 216   (:metaclass event-class)
 217   (:event-type :button-press))
 218
 219 (defclass 2-button-press-event (button-press-event)
 220   ()
 221   (:metaclass event-class)
 222   (:event-type :2button-press))
 223
 224 (defclass 3-button-press-event (button-press-event)
 225   ()
 226   (:metaclass event-class)
 227   (:event-type :3button-press))
 228
 229 (defclass button-release-event (button-event)
 230   ()
 231   (:metaclass event-class)
 232   (:event-type :button-release))
 233
 234
 235 (defclass key-event (timed-event)
 236   ((state
 237     :allocation :alien
 238     :accessor event-state
 239     :initarg :state
 240     :type modifier-type)
 241    (keyval
 242     :allocation :alien
 243     :accessor event-keyval
 244     :initarg :keyval
 245     :type unsigned-int)
 246    (length
 247     :allocation :alien
 248     :accessor event-length
 249     :initarg :length
 250     :type unsigned-int)
 251    (string
 252     :allocation :alien
 253     :accessor event-string
 254     :initarg :string
 255     :type string)
 256    (hardware-keycode
 257     :allocation :alien
 258     :accessor event-hardware-keycode
 259     :initarg :hardware-keycode
 260     :type (unsigned 16))
 261    (group
 262     :allocation :alien
 263     :accessor event-group
 264     :initarg :group
 265     :type (unsigned 8)))
 266   (:metaclass event-class))
 267
 268 (defclass key-press-event (key-event)
 269   ()
 270   (:metaclass event-class)
 271   (:event-type :key-press))
 272
 273 (defclass key-release-event (key-event)
 274   ()
 275   (:metaclass event-class)
 276   (:event-type :key-release))
 277
 278
 279 (defclass crossing-event (event)
 280   ((subwindow
 281     :allocation :alien
 282     :accessor event-subwindow
 283     :initarg :subwindow
 284     :type window)
 285    (time
 286     :allocation :alien
 287     :accessor event-time
 288     :initarg :time
 289     :type (unsigned 32))
 290    (x
 291     :allocation :alien
 292     :accessor event-x
 293     :initarg :x
 294     :type double-float)
 295    (y
 296     :allocation :alien
 297     :accessor event-y
 298     :initarg :y
 299     :type double-float)
 300    (root-x
 301     :allocation :alien
 302     :accessor event-root-x
 303     :initarg :root-x
 304     :type double-float)
 305    (root-y
 306     :allocation :alien
 307     :accessor event-root-y
 308     :initarg :root-y
 309     :type double-float)
 310    (mode
 311     :allocation :alien
 312     :accessor event-mode
 313     :initarg :mode
 314     :type crossing-mode)
 315    (detail
 316     :allocation :alien
 317     :accessor event-detail
 318     :initarg :detail
 319     :type notify-type)
 320    (focus
 321     :allocation :alien
 322     :accessor event-focus
 323     :initarg :focus
 324     :type boolean)
 325    (state
 326     :allocation :alien
 327     :accessor event-state
 328     :initarg :state
 329     :type unsigned-int))
 330   (:metaclass event-class))
 331
 332
 333 (defclass enter-notify-event (crossing-event)
 334   ()
 335   (:metaclass event-class)
 336   (:event-type :enter-notify))
 337
 338 (defclass leave-notify-event (crossing-event)
 339   ()
 340   (:metaclass event-class)
 341   (:event-type :leave-notify))
 342
 343 (defclass focus-change-event (event)
 344   ((in
 345     :allocation :alien
 346     :accessor event-in
 347     :initarg :in
 348     :type (bool 16)))
 349   (:metaclass event-class)
 350   (:event-type :focus-change))
 351
 352 (defclass configure-event (event)
 353   ((x
 354     :allocation :alien
 355     :accessor event-x
 356     :initarg :x
 357     :type int)
 358    (y
 359     :allocation :alien
 360     :accessor event-y
 361     :initarg :y
 362     :type int)
 363    (width
 364     :allocation :alien
 365     :accessor event-width
 366     :initarg :width
 367     :type int)
 368    (height
 369     :allocation :alien
 370     :accessor event-height
 371     :initarg :height
 372     :type int))
 373   (:metaclass event-class)
 374   (:event-type :configure))
 375
 376 (defclass map-event (event)
 377   ()
 378   (:metaclass event-class)
 379   (:event-type :map))
 380
 381 (defclass unmap-event (event)
 382   ()
 383   (:metaclass event-class)
 384   (:event-type :unmap))
 385
 386 (defclass property-notify-event (event)
 387   ()
 388   (:metaclass event-class)
 389   (:event-type :property-notify))
 390
 391 (defclass selection-clear-event (event)
 392   ()
 393   (:metaclass event-class)
 394   (:event-type :selection-clear))
 395
 396 (defclass selection-request-event (event)
 397   ()
 398   (:metaclass event-class)
 399   (:event-type :selection-request))
 400
 401 (defclass selection-notify-event (event)
 402   ()
 403   (:metaclass event-class)
 404   (:event-type :selection-notify))
 405
 406 (defclass dnd-event (event)
 407   ((context
 408     :allocation :alien
 409     :accessor event-contex
 410     :initarg :context
 411     :type drag-context)
 412    (time
 413     :allocation :alien
 414     :accessor event-time
 415     :initarg :time
 416     :type (unsigned 32))
 417    (x-root
 418     :allocation :alien
 419     :accessor event-x-root
 420     :initarg :x-root
 421     :type short)
 422    (y-root
 423     :allocation :alien
 424     :accessor event-y-root
 425     :initarg :y-root
 426     :type short))
 427   (:metaclass event-class))
 428
 429 (defclass drag-enter-event (dnd-event)
 430   ()
 431   (:metaclass event-class)
 432   (:event-type :drag-enter))
 433
 434 (defclass drag-leave-event (dnd-event)
 435   ()
 436   (:metaclass event-class)
 437   (:event-type :drag-leave))
 438
 439 (defclass drag-motion-event (dnd-event)
 440   ()
 441   (:metaclass event-class)
 442   (:event-type :drag-motion))
 443
 444 (defclass drag-status-event (dnd-event)
 445   ()
 446   (:metaclass event-class)
 447   (:event-type :drag-status))
 448
 449 (defclass drot-start-event (dnd-event)
 450   ()
 451   (:metaclass event-class)
 452   (:event-type :drop-start))
 453
 454 (defclass drop-finished-event (dnd-event)
 455   ()
 456   (:metaclass event-class)
 457   (:event-type :drop-finished))
 458
 459 (defclass client-event (event)
 460   ()
 461   (:metaclass event-class)
 462   (:event-type :client-event))
 463
 464 (defclass visibility-notify-event (event)
 465   ((state
 466     :allocation :alien
 467     :accessor event-state
 468     :initarg :state
 469     :type visibility-state))
 470   (:metaclass event-class)
 471   (:event-type :visibility-notify))
 472
 473 (defclass no-expose-event (event)
 474   ()
 475   (:metaclass event-class)
 476   (:event-type :no-expose))
 477
 478 (defclass scroll-event (timed-event)
 479   ((x
 480     :allocation :alien
 481     :accessor event-x
 482     :initarg :x
 483     :type double-float)
 484    (y
 485     :allocation :alien
 486     :accessor event-y
 487     :initarg :y
 488     :type double-float)
 489    (state
 490     :allocation :alien
 491     :accessor event-state
 492     :initarg :state
 493     :type modifier-type)
 494    (direction
 495     :allocation :alien
 496     :accessor event-direction
 497     :initarg :direction
 498     :type scroll-direction)
 499    (root-x
 500     :allocation :alien
 501     :accessor event-root-x
 502     :initarg :root-x
 503     :type double-float)
 504    (root-y
 505     :allocation :alien
 506     :accessor event-root-y
 507     :initarg :root-y
 508     :type double-float))
 509   (:metaclass event-class)
 510   (:event-type :scroll))
 511
 512 (defclass setting-event (event)
 513   ((action
 514     :allocation :alien
 515     :accessor event-action
 516     :initarg :action
 517     :type setting-action)
 518    (name
 519     :allocation :alien
 520     :accessor event-name
 521     :initarg :name
 522     :type string))
 523   (:metaclass event-class)
 524   (:event-type :setting))
 525
 526 (defclass proximity-event (timed-event)
 527   ((device
 528     :allocation :alien
 529     :accessor event-device
 530     :initarg :device
 531     :type device))
 532   (:metaclass event-class))
 533
 534 (defclass proximity-in-event (proximity-event)
 535   ()
 536   (:metaclass event-class)
 537   (:event-type :proximity-in))
 538
 539 (defclass proximity-out-event (proximity-event)
 540   ()
 541   (:metaclass event-class)
 542   (:event-type :proximity-out))
 543
 544 (defclass window-state-event (event)
 545   ((change-mask
 546     :allocation :alien
 547     :accessor event-change-mask
 548     :initarg :change-mask
 549     :type window-state)
 550    (new-window-state
 551     :allocation :alien
 552     :accessor event-new-window-state
 553     :initarg :new-window-state
 554     :type window-state))
 555   (:metaclass event-class)
 556   (:event-type :window-state))
 557
 558 (defclass owner-change-event (event)
 559   ()
 560   (:metaclass event-class)
 561   (:event-type :owner-change))
 562