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