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