;;;; EVENT.LISP

;;; $Revision: 1.2 $
;;; Copyright © 1999 Paul Foley (mycroft@actrix.gen.nz)
;;; All rights reserved.  Use and verbatim redistribution permitted.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.

(in-package "CL-USER")

(unless (member :CLX *features*)
  (error "CLX must be loaded before EVENT."))

(defpackage "EVENT" (:use "COMMON-LISP" "XLIB")
  (:shadow XLIB:EVENT-HANDLER XLIB:PROCESS-EVENT)
  (:export "ADD-EVENT-MAPPING" "REMOVE-EVENT-MAPPING"
	   "REMOVE-EVENT-MAPPING-FOR-OBJECT"
	   "REMOVE-EVENT-MAPPING-FOR-DISPLAY"

	   "EVENT" "X-EVENT" "BUTTON-EVENT" "KEY-EVENT" "MOTION-EVENT"
	   "BUTTON-PRESS-EVENT" "BUTTON-RELEASE-EVENT" "BUTTON-MOTION-EVENT"
	   "KEY-PRESS-EVENT" "KEY-RELEASE-EVENT" "ENTER-EVENT" "LEAVE-EVENT"
	   "CREATE-EVENT" "DESTROY-EVENT" "MAP-EVENT" "UNMAP-EVENT"
	   "MAP-REQUEST-EVENT" "EXPOSE-EVENT" "PROPERTY-CHANGE-EVENT"
	   "CLIENT-MESSAGE-EVENT" "CONFIGURE-NOTIFY-EVENT" "RESIZE-EVENT"
	   "MOVE-EVENT" "CLICK-EVENT" "DOUBLE-CLICK-EVENT" "TRIPLE-CLICK-EVENT"
	   "MULTIPLE-CLICK-EVENT"

	   "CLX-EVENT" "EVENT-DISPLAY" "EVENT-TIME" "EVENT-BUTTON"
	   "EVENT-MODIFIERS" "EVENT-X-POSITION" "EVENT-Y-POSITION"
	   "EVENT-KEYCODE" "EVENT-WINDOW-PARENT" "EVENT-WINDOW"
	   "EVENT-WINDOW-WIDTH" "EVENT-WINDOW-HEIGHT"
	   "EVENT-WINDOW-BORDER-WIDTH" "EVENT-OVERRIDE-REDIRECT-P" "EVENT-X"
	   "EVENT-Y" "EVENT-WIDTH" "EVENT-HEIGHT" "EVENT-PROPERTY"
	   "EVENT-MESSAGE-TYPE" "EVENT-DATA-FORMAT" "EVENT-DATA"
	   "EVENT-WINDOW-X" "EVENT-WINDOW-Y" "EVENT-CLICKS"
	   
	   "PROCESS-EVENT"
	   "EVENT-OBJECT" "X-EVENT-OBJECT"
	   "CLX-WINDOW"
	   "EVENT-HANDLER"
	   "COMPRESS-MOTION-EVENTS" "COMPRESS-EXPOSE-EVENTS"
	   "ENABLE-EVENT-HANDLING" "DISABLE-EVENT-HANDLING"))

(in-package "EVENT")

(defvar *event-map* (make-hash-table :test #'eq))

(defun add-event-mapping (window object)
  (setf (gethash window *event-map*) object))

(defun remove-event-mapping (window)
  (remhash window *event-map*))

(defun remove-event-mapping-for-object (object)
  (maphash (lambda (window event-object)
	     (when (eq event-object object)
	       (remove-event-mapping window)))
	   *event-map*))

(defun remove-event-mapping-for-display (display)
  (maphash (lambda (window object)
	     (declare (ignore object))
	     (when (eq (xlib:window-display window) display)
	       (remove-event-mapping window)))
	   *event-map*))

(defclass event () ())

(defclass x-event (event)
  ((display :initform nil :initarg :display :accessor event-display)
   (clx-event :initform nil :initarg :clx-event :accessor clx-event)
   (timestamp :initform 0 :initarg :timestamp :accessor event-time)))

(defclass button-event (x-event)
  ((button :initform nil :initarg :button :accessor event-button)
   (modifiers :initform 0 :initarg :modifiers :accessor event-modifiers)
   (x :initarg :x :accessor event-x-position)
   (y :initarg :y :accessor event-y-position)))

(defclass key-event (x-event)
  ((keycode :initform nil :initarg :keycode :accessor event-keycode)
   (modifiers :initform 0 :initarg :modifiers :accessor event-modifiers)))

(defclass motion-event (x-event)
  ((x :initarg :x :accessor event-x-position)
   (y :initarg :y :accessor event-y-position)))

(defclass button-press-event (button-event) ())
(defclass button-release-event (button-event) ())
(defclass button-motion-event (button-event motion-event) ())

(defclass key-press-event (key-event) ())
(defclass key-release-event (key-event) ())

(defclass enter-event (x-event) ())
(defclass leave-event (x-event) ())

(defclass create-event (x-event)
  ((parent :initarg :parent :accessor event-window-parent)
   (window :initarg :window :accessor event-window)
   (x :initarg :x :accessor event-x-position)
   (y :initarg :y :accessor event-y-position)
   (width :initarg :width :accessor event-window-width)
   (height :initarg :height :accessor event-window-height)
   (border :initarg :border :accessor event-window-border-width)
   (redirect :initarg :redirect :accessor event-override-redirect-p)))

(defclass destroy-event (x-event)
  ((window :initarg :window :accessor event-window)))

(defclass map-event (x-event)
  ((window :initarg :window :accessor event-window)))

(defclass unmap-event (x-event)
  ((window :initarg :window :accessor event-window)))

(defclass map-request-event (x-event)
  ((window :initarg :window :accessor event-window)))

(defclass expose-event (x-event)
  ((x :initarg :x :accessor event-x)
   (y :initarg :y :accessor event-y)
   (width :initarg :width :accessor event-width)
   (height :initarg :height :accessor event-height)))

(defclass property-change-event (x-event)
  ((property :initarg :property :accessor event-property)))

(defclass client-message-event (x-event)
  ((type :initarg :type :accessor event-message-type)
   (format :initarg :format :accessor event-data-format)
   (data :initarg :data :accessor event-data)))

(defclass configure-notify-event (x-event)
  ((window :initarg :window :accessor event-window)
   (x :initarg :x :accessor event-window-x)
   (y :initarg :y :accessor event-window-y)
   (width :initarg :width :accessor event-window-width)
   (height :initarg :height :accessor event-window-height)
   (border :initarg :border :accessor event-window-border-width)))

(defclass resize-event (x-event)
  ((width :initarg :width :accessor event-width)
   (height :initarg :height :accessor event-height)))

(defclass move-event (x-event)
  ((x :initarg :x :accessor event-x)
   (y :initarg :y :accessor event-y)))

(defclass click-event (x-event)
  ((button :initform nil :initarg :button :accessor event-button)
   (modifiers :initform 0 :initarg :modifiers :accessor event-modifiers)
   (x :initarg :x :accessor event-x-position)
   (y :initarg :y :accessor event-y-position)))

(defclass multiple-click-event (x-event)
  ((button :initform nil :initarg :button :accessor event-button)
   (modifiers :initform 0 :initarg :modifiers :accessor event-modifiers)
   (x :initarg :x :accessor event-x-position)
   (y :initarg :y :accessor event-y-position)
   (clicks :initarg :clicks :accessor event-clicks)))

(defclass double-click-event (multiple-click-event) ())

(defclass triple-click-event (multiple-click-event) ())

(defun process-event (display &optional default-handler)
  (xlib:process-event
   display
   :handler
   (lambda (&rest event
	    &key display event-key event-window timestamp &allow-other-keys)
     (let ((object (gethash event-window *event-map*)))
       (if object
	   (macrolet ((emit (type &rest keys)
			`(event-handler object (make-instance ,type
						 :display display
						 :clx-event event
						 :timestamp timestamp
						 ,@keys))))
	     (case event-key
	       (:button-press (emit 'button-press-event
				      :button (getf event :code)
				      :modifiers (logand #x7F
						   (getf event :state))
				      :x (getf event :x)
				      :y (getf event :y)))
	       (:button-release (emit 'button-release-event
					:button (getf event :code)
					:modifiers (logand #x7F
						     (getf event :state))
					:x (getf event :x)
					:y (getf event :y)))
	       (:circulate-notify (emit 'x-event)) ;@@ make specific
	       (:circulate-request (emit 'x-event)) ;@@
	       (:client-message (emit 'client-message-event
				      :type (getf event :type)
				      :format (getf event :format)
				      :data (getf event :data)))
	       (:colormap-notify (emit 'x-event)) ;@@
	       (:configure-notify (emit 'configure-notify-event
					:window (getf event :window)
					:x (getf event :x)
					:y (getf event :y)
					:width (getf event :width)
					:height (getf event :height)
					:border (getf event :border-width)))
	       (:configure-request (emit 'x-event)) ;@@
	       (:create-notify (emit 'create-event
				       :parent (getf event :parent)
				       :window (getf event :window)
				       :x (getf event :x)
				       :y (getf event :y)
				       :width (getf event :width)
				       :height (getf event :height)
				       :border (getf event :border-width)
				       :redirect (getf event
						       :override-redirect-p)))
	       (:destroy-notify (emit 'destroy-event
					:window (getf event :window)))
	       (:enter-notify (emit 'enter-event))
	       (:exposure (emit 'expose-event
				  :x (getf event :x) :y (getf event :y)
				  :width (getf event :width)
				  :height (getf event :height)))
	       (:focus-in (emit 'x-event)) ;@@
	       (:focus-out (emit 'x-event)) ;@@
	       (:graphics-exposure (emit 'x-event)) ;@@
	       (:gravity-notify (emit 'x-event)) ;@@
	       (:keymap-notify (emit 'x-event)) ;@@
	       (:key-press (emit 'key-press-event
				   :keycode (getf event :code)
				   :modifiers (getf event :state)))
	       (:key-release (emit 'key-release-event
				     :keycode (getf event :code)
				     :modifiers (getf event :state)))
	       (:leave-notify (emit 'leave-event))
	       (:map-notify (emit 'map-event
				    :window (getf event :window)))
	       (:map-request (emit 'map-request-event
				     :window (getf event :window)))
	       (:motion-notify (emit 'motion-event ; or button-motion-event
				       :x (getf event :x)
				       :y (getf event :y)))
	       (:no-exposure (emit 'x-event)) ;@@
	       (:property-notify (emit 'property-change-event
					 :property (getf event :atom)))
	       (:reparent-notify (emit 'x-event)) ;@@
	       (:resize-request (emit 'x-event)) ;@@
	       (:selection-clear (emit 'x-event)) ;@@
	       (:selection-notify (emit 'x-event)) ;@@
	       (:selection-request (emit 'x-event)) ;@@
	       (:unmap-notify (emit 'unmap-event
				      :window (getf event :window)))
	       (:visibility-notify (emit 'x-event)) ;@@
	       (t (emit 'x-event))))
	 (when default-handler
	   (funcall default-handler event))))
     t)))

(defclass event-object () ())

(defgeneric event-handler (object event)
  (:documentation "Handle an event")
  (:method ((object event-object) (event event))))

(defclass x-event-object (event-object)
  ((window :initform nil :initarg :window :accessor clx-window)))

(defmethod initialize-instance :after ((obj x-event-object) &rest initargs)
  (declare (ignore initargs))
  (when (clx-window obj)
    (add-event-mapping (clx-window obj) obj)))

(defmethod (setf clx-window) :around (value (obj x-event-object))
  (when (clx-window obj)
    (remove-event-mapping (clx-window obj)))
  (prog1 (call-next-method)
    (when (clx-window obj)
      (add-event-mapping (clx-window obj) obj))))

(defmacro while (test &rest body)
  (let ((result (gensym)))
    `(do ((,result nil (progn ,@body)))
         ((not ,test) ,result))))

(defmacro defcompressor (type name (event &rest args) slots &body body)
  (let ((window (gensym)))
    `(defun ,name (,event ,@args)
       (let ((,window (getf (clx-event ,event) :event-window)))
	 (while (xlib:event-cond ((event-display ,event) :timeout 0)
		  (,type (event-window ,@slots) (eq event-window ,window)
			 ,@body
			 t)))))))

(defcompressor :MOTION-NOTIFY compress-motion-events (event) (x y)
  (setf (event-x-position event) x)
  (setf (event-y-position event) y))

(defcompressor :EXPOSURE compress-expose-events (event &optional (ch t))
                                                (x y width height)
  (when ch
    (let ((nx (+ x width))
	  (ny (+ y height))
	  (ox (+ (event-x event) (event-width event)))
	  (oy (+ (event-y event) (event-height event))))
      (when (< x (event-x event)) (setf (event-x event) x))
      (when (< y (event-y event)) (setf (event-y event) y))
      (when (> nx ox) (setf (event-width event) (- nx (event-x event))))
      (when (> ny oy) (setf (event-height event) (- ny (event-y event)))))))

#+Allegro
(defvar *.event-handlers.* (make-hash-table :size 5 :test #'eq))

(defun enable-event-handling (display)
  #+CMU (ext:enable-clx-event-handling display #'process-event)
  #+Allegro
  (setf (gethash display *.event-handlers.*)
     (mp:process-run-function "CLX server"
	#'(lambda (display) (loop (process-event display)))
	display)))

(defun disable-event-handling (display)
  (remove-event-mapping-for-display display)
  #+CMU (ext:disable-clx-event-handling display)
  #+Allegro
  (let ((proc (gethash display *.event-handlers.*)))
    (when proc (mp:process-kill proc))))