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

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