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