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

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