+;; Common Lisp bindings for GTK+ v2.0
+;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;; $Id: gdkevents.lisp,v 1.1 2001/05/11 16:20:20 espen Exp $
+
+(in-package "GDK")
+
+
+(defvar *event-classes* (make-hash-table))
+
+(defun %type-of-event (location)
+ (class-name
+ (gethash
+ (funcall (intern-reader-function 'event-type) location 0)
+ *event-classes*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass event (boxed)
+ ((%type
+ :allocation :alien
+ :type event-type)
+ (window
+ :allocation :alien
+ :accessor event-window
+ :initarg :window
+ :type window)
+ (send-event
+ :allocation :alien
+ :accessor event-send-event
+ :initarg :send-event
+ :type (boolean 8))
+ (%align :allocation :alien :offset 2 :type (unsigned 8)))
+ (:metaclass boxed-class)))
+
+
+(defmethod initialize-instance ((event event) &rest initargs)
+ (declare (ignore initargs))
+ (with-slots (location %type) event
+ (setf location (%event-new))
+ (setf %type (event-class-type (class-of event))))
+ (call-next-method))
+
+(deftype-method translate-from-alien
+ event (type-spec location &optional weak-ref)
+ (declare (ignore type-spec))
+ `(let ((location ,location))
+ (unless (null-pointer-p location)
+ (ensure-proxy-instance (%type-of-event location) location ,weak-ref))))
+
+(defbinding %event-new () pointer)
+
+
+;;;; Metaclass for event classes
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass event-class (proxy-class)
+ ((event-type :reader event-class-type))))
+
+
+(defmethod shared-initialize ((class event-class) names
+ &rest initargs &key type)
+ (declare (ignore initargs names))
+ (call-next-method)
+ (setf (slot-value class 'event-type) (first type))
+ (setf (gethash (first type) *event-classes*) class))
+
+
+(defmethod validate-superclass
+ ((class event-class) (super pcl::standard-class))
+ (subtypep (class-name super) 'event))
+
+
+;;;;
+
+(defclass timed-event (event)
+ ((time
+ :allocation :alien
+ :accessor event-time
+ :initarg :time
+ :type (unsigned 32)))
+ (:metaclass proxy-class))
+
+(defclass delete-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :delete))
+
+(defclass destroy-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :destroy))
+
+(defclass expose-event (event)
+ ((x
+ :allocation :alien
+ :accessor event-x
+ :initarg :x
+ :type int)
+ (y
+ :allocation :alien
+ :accessor event-y
+ :initarg :y
+ :type int)
+ (width
+ :allocation :alien
+ :accessor event-width
+ :initarg :width
+ :type int)
+ (height
+ :allocation :alien
+ :accessor event-height
+ :initarg :height
+ :type int)
+ (count
+ :allocation :alien
+ :accessor event-count
+ :initarg :count
+ :type int))
+ (:metaclass event-class)
+ (:type :expose))
+
+(defclass motion-notify-event (timed-event)
+ ((x
+ :allocation :alien
+ :accessor event-x
+ :initarg :x
+ :type double-float)
+ (y
+ :allocation :alien
+ :accessor event-y
+ :initarg :y
+ :type double-float)
+ (state
+ :allocation :alien
+ :offset #.(size-of 'pointer)
+ :accessor event-state
+ :initarg :state
+ :type unsigned-int)
+ (is-hint
+ :allocation :alien
+ :accessor event-is-hint
+ :initarg :is-hint
+ :type (signed 16) ; should it be (boolean 16)?
+ )
+ (device
+ :allocation :alien
+ :offset 2
+ :accessor event-device
+ :initarg :device
+ :type device)
+ (root-x
+ :allocation :alien
+ :accessor event-root-x
+ :initarg :root-x
+ :type double-float)
+ (root-y
+ :allocation :alien
+ :accessor event-root-y
+ :initarg :root-y
+ :type double-float))
+ (:metaclass event-class)
+ (:type :motion-notify))
+
+(defclass button-press-event (timed-event)
+ ((x
+ :allocation :alien
+ :accessor event-x
+ :initarg :x
+ :type double-float)
+ (y
+ :allocation :alien
+ :accessor event-y
+ :initarg :y
+ :type double-float)
+ (state
+ :allocation :alien
+ :offset #.(size-of 'pointer)
+ :accessor event-state
+ :initarg :state
+ :type modifier-type)
+ (button
+ :allocation :alien
+ :accessor event-button
+ :initarg :button
+ :type unsigned-int)
+ (device
+ :allocation :alien
+ :accessor event-device
+ :initarg :device
+ :type device)
+ (root-x
+ :allocation :alien
+ :accessor event-root-x
+ :initarg :root-x
+ :type double-float)
+ (root-y
+ :allocation :alien
+ :accessor event-root-y
+ :initarg :root-y
+ :type double-float))
+ (:metaclass event-class)
+ (:type :button-press))
+
+(defclass 2-button-press-event (button-press-event)
+ ()
+ (:metaclass event-class)
+ (:type :2button-press))
+
+(defclass 3-button-press-event (button-press-event)
+ ()
+ (:metaclass event-class)
+ (:type :3button-press))
+
+(defclass button-release-event (button-press-event)
+ ()
+ (:metaclass event-class)
+ (:type :button-release))
+
+(defclass key-press-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :key-press))
+
+(defclass key-release-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :key-release))
+
+(defclass enter-notify-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :enter-notify))
+
+(defclass leave-notify-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :leave-notify))
+
+(defclass focus-change-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :focus-change))
+
+(defclass configure-event (event)
+ ((x
+ :allocation :alien
+ :accessor event-x
+ :initarg :x
+ :type int)
+ (y
+ :allocation :alien
+ :accessor event-y
+ :initarg :y
+ :type int)
+ (width
+ :allocation :alien
+ :accessor event-width
+ :initarg :width
+ :type int)
+ (height
+ :allocation :alien
+ :accessor event-height
+ :initarg :height
+ :type int))
+ (:metaclass event-class)
+ (:type :configure))
+
+(defclass map-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :map))
+
+(defclass unmap-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :unmap))
+
+(defclass property-notify-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :property-notify))
+
+(defclass selection-clear-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :selection-clear))
+
+(defclass selection-request-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :selection-request))
+
+(defclass selection-notify-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :selection-notify))
+
+(defclass drag-enter-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-enter))
+
+(defclass drag-leave-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-leave))
+
+(defclass drag-motion-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-motion))
+
+(defclass drag-status-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-status))
+
+(defclass drag-start-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-start))
+
+(defclass drag-finished-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :drag-finished))
+
+(defclass client-event (event)
+ ()
+ (:metaclass event-class)
+ ;(:type :client-event)
+ )
+
+(defclass visibility-notify-event (event)
+ ((state
+ :allocation :alien
+ :accessor event-state
+ :initarg :state
+ :type visibility-state))
+ (:metaclass event-class)
+ (:type :visibility-notify))
+
+(defclass no-expose-event (event)
+ ()
+ (:metaclass event-class)
+ (:type :no-expose))
+
+(defclass scroll-event (timed-event)
+ ()
+ (:metaclass event-class)
+ (:type :scroll))
+
+(defclass setting-event (timed-event)
+ ()
+ (:metaclass event-class)
+ (:type :setting))
~mdw / clg / commitdiff