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