;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 149149
;;;			       AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

#| To Do:

1. Hooks are in place to handle button mult-click and hold using 3 extra modifier state bits
   (:hold :click :double), but the interface isn't there yet.

2. Add translation from symbolic mouse button names to actual mouse button/modifier specs.
   Use the keysym translation facilities (define 5 keysyms for each of the mouse keys,
   and use define-keysym)

|#

(in-package "CLUEI")

(export '( event
	  ;; Event slots
	  key display contact character keysym above-sibling
	  atom border-width child code colormap configure-p count data
	  drawable event-window focus-p format height hint-p installed-p
	  keymap kind major minor mode name new-p override-redirect-p
	  parent place property requestor root root-x root-y same-screen-p
	  selection send-event-p state target time type width window x y

	  mode-type	   	  
	  *remap-events*
	  *restrict-events*
	  add-mode
	  delete-mode
	  with-mode
	  with-event-mode
	  contact-mode
	  contact-super-mode

	  *contact*
	  apply-action
	  call-action
	  defaction
	  describe-action
	  eval-action
	  ignore-action 
	  perform-callback
	  throw-action
	  trace-action
	  with-event
	  processing-event-p 
	  
	  add-before-action
	  delete-before-action
	  process-all-events
	  process-next-event
	  handle-event
	  translate-event
	  defevent
	  undefevent
	  event-actions
	  add-event
	  delete-event
	  describe-event-translations
	  add-timer
	  delete-timer
	  ))

;; INPUT PROCESSING

;; Rather than pass around event parameters in long plists,
;; parameters are stuffed into this structure.  For any one event,
;; most slots are undefined, and these are initialized to NIL.
;; Event structures are kept on a resource and re-used.
;; The only reason event is a class and not a structure is because
;; we want to use with-slots.

(defclass event ()
  ((key)					; Event key
   (display)					; Display event was reported to
   (contact)					; Contact the event is directed to
   (character)					; character from code and state
   (keysym)					; keysym from code and state
   (plist :initform nil :type list)		; Place for extension data
   ;; The following are from the CLX event
   (above-sibling)				; Used by :configure-notify :configure-request
   (atom)					; Used by :property-notify 
   (border-width)				; Used by :create-notify :configure-notify :configure-request
   (child)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
   (code)					; Used by :key-press :key-release :button-press :button-release
   (colormap)					; Used by :colormap-notify
   (sequence)					; Used by all except :keymap-notify
   (configure-p)				; Used by :unmap-notify
   (count)					; Used by :exposure :graphics-exposure :mapping-notify
   (data)					; Used by :client-message :timer
   (drawable)					; Used by :graphics-exposure :no-exposure
   (event-window)				; Used by :destroy-notify :unmap-notify :map-notify :reparent-notify
						;         :configure-notify :gravity-notify :circulate-notify
   (focus-p)					; Used by :enter-notify :leave-notify
   (format)					; Used by :client-message
   (height)					; Used by :exposure :graphics-exposure :create-notify :configure-notify
						;         :configure-request :resize-request
   (hint-p)					; Used by :motion-notify
   (installed-p)				; Used by :colormap-notify
   (keymap)					; Used by :keymap-notify
   (kind)					; Used by :enter-notify :leave-notify :focus-in :focus-out
   (major)					; Used by :graphics-exposure :no-exposure
   (minor)					; Used by :graphics-exposure :no-exposure
   (mode)					; Used by :enter-notify :leave-notify :focus-in :focus-out
   (name)					; Used by :timer
   (new-p)					; Used by :colormap-notify
   (override-redirect-p)			; Used by :create-notify :map-notify
						;                         :reparent-notify :configure-notify
   (parent)					; Used by :create-notify :map-request :reparent-notify :configure-request
						;         :circulate-notify :circulate-request 
   (place)					; Used by :circulate-notify :circulate-request
   (property)					; Used by :selection-request :selection-notify
   (requestor)					; Used by :selection-request
   (root)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
   (root-x)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
   (root-y)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
   (same-screen-p)				; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
   (selection)					; Used by :selection-clear :selection-request :selection-notify
   (send-event-p)				; Used by -all events-
   (state)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify
						;         :visibility-notify :property-notify
   (target)					; Used by :selection-request :selection-notify
   (time)					; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify :property-notify
						;         :selection-clear :selection-request :selection-notify
   (type)					; Used by :client-message
   (width)					; Used by :exposure :graphics-exposure :create-notify :configure-notify
						;         :configure-request :resize-request
   (window)					; Used by all events except :graphics-exposure :no-exposure :mapping-notify
   (x)						; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify :exposure
						;         :graphics-exposure :create-notify :reparent-notify
						;         :configure-notify :configure-request :gravity-notify
   (y)						; Used by :key-press :key-release :button-press :button-release
						;         :motion-notify :enter-notify :leave-notify :exposure
						;         :graphics-exposure :create-notify :reparent-notify
						;         :configure-notify :configure-request :gravity-notify
  )
  #+pcl (:metaclass structure-class)
  (:documentation "CLUE event structure, one slot for every event value.  No methods."))

(defmethod print-object ((instance event) stream)
  #+lispm
  (si:printing-random-object (instance stream)
    (with-slots (key contact) instance
      (format stream "Event ~a for ~a" key (and (typep contact 'contact) (contact-name contact)))))
  #-lispm
  (progn
    (write-string "#<EVENT " stream)
    (with-slots (key contact) instance
      (princ key stream)
      (when (typep contact 'contact)
	(write-string " for " stream)
	(princ (contact-name contact) stream)))
    (write-char #\> stream)))

;;; PROCESS-NEXT-EVENT copies event data into an event structure.  After the
;;; event is processed, its put back into *event-cache* to be re-used on the
;;; next event.  This is done to reduce consing.  Care is taken to shield the
;;; application progammer from the actual event structure to prevent saving the
;;; event structure in application data structures.  If an application did this,
;;; the event would be destructively modified on subsequent events.
(defvar *event-cache* nil)

#+ explorer
(let ((nil-event (make-instance 'event)))
  (declare (type event nil-event))
  (with-slots
    (
     above-sibling atom border-width character child
     code colormap configure-p contact count data display drawable event-window focus-p
     format height hint-p installed-p key keymap keysym kind major minor mode name
     new-p override-redirect-p parent place plist property requestor root root-x root-y
     same-screen-p selection send-event-p sequence state target time type width
     window x y
     )
    (the event nil-event)		
    (setf
      above-sibling            nil
      atom                     nil
      border-width             nil
      character                nil
      child                    nil
      code                     nil
      colormap                 nil
      configure-p              nil
      contact                  nil
      count                    nil
      data                     nil
      display                  nil
      drawable                 nil
      event-window             nil
      focus-p                  nil
      format                   nil
      height                   nil
      hint-p                   nil
      installed-p              nil
      key                      nil
      keymap                   nil
      keysym                   nil
      kind                     nil
      major                    nil
      minor                    nil
      mode                     nil
      name                     nil
      new-p                    nil
      override-redirect-p      nil
      parent                   nil
      place                    nil
      plist                    nil
      property                 nil
      requestor                nil
      root                     nil
      root-x                   nil
      root-y                   nil
      same-screen-p            nil
      selection                nil
      send-event-p             nil
      sequence                 nil
      state                    nil
      target                   nil
      time                     nil
      type                     nil
      width                    nil
      window                   nil
      x                        nil
      y                        nil
      ))

  (defun allocate-event ()
    (let ((event (or (pop *event-cache*)
		     (make-instance 'event))))
      (si:%blt-typed
	(1+ (si:%pointer nil-event))
	(1+ (si:%pointer event))
	49 1)
      event)))
  
#- explorer
(progn

(defun allocate-event ()
  ;; Get an event structure, initializing all slots to NIL
  (initialize-event (or (pop *event-cache*)
			(make-instance 'event))))

(defmethod initialize-event ((event event))
    (with-slots (key display contact character keysym plist code state time event-window
		     root drawable window child parent root-x root-y x y
		     width height border-width override-redirect-p same-screen-p
		     configure-p hint-p kind mode keymap focus-p count major minor
		     above-sibling place atom selection requestor target property
		     colormap new-p installed-p format type data name send-event-p
		     )
		(the event event)		
      (setf key	nil
	    display nil				; Display event was reported to
	    contact nil				; Contact the event is directed to
	    character nil			; character from code and state
	    keysym nil				; keysym from code and state
	    ;; The following are from the CLX event
	    code nil
	    state nil
	    time nil
	    event-window nil
	    root nil
	    drawable nil
	    window nil
	    child nil
	    parent nil
	    root-x nil
	    root-y nil
	    x nil
	    y nil
	    width nil
	    height nil
	    border-width nil
	    override-redirect-p nil
	    same-screen-p nil
	    configure-p nil
	    hint-p nil
	    kind nil
	    mode nil
	    keymap nil
	    focus-p nil
	    count nil
	    major nil
	    minor nil
	    above-sibling nil
	    place nil
	    atom nil
	    selection nil
	    requestor nil
	    target nil
	    property nil
	    colormap nil
	    new-p nil
	    installed-p nil
	    format nil
	    type nil
	    data nil
	    send-event-p nil
	    name nil
	    plist nil
	    ))
    event)

)

(defun deallocate-event (event)
  ;; Return an event to the cache, where it can be re-used.
  (push event *event-cache*))


;;-----------------------------------------------------------------------------
;; MODES

;;; Applications may find it necessary to establish a special input
;;; "mode" in which the user is temporarily required to direct input
;;; to one or more specific contacts. In such a mode, user input
;;; events directed to other contacts are not handled normally, but
;;; instead are either ignored or acknowledged with some kind of
;;; warning.

(deftype mode-type () '(member :non-exclusive :exclusive :spring-loaded))

(defparameter *remap-events* '(:key-press :key-release :button-press :button-release)
  "These events are sent to the most recent :spring-loaded contact on the mode-stack.")

(defparameter *restrict-events*
	      '(:motion-notify :enter-notify :leave-notify)
  "These 'user' events are sent to the restrict-action of the first
   :exclusive contact on the mode-stack")

(defparameter *sensitive-events*
	      '(:key-press :key-release :button-press :button-release
		:motion-notify :enter-notify :leave-notify
		:focus-in)
  "These 'user' events are ignored by an insensitive contact.")

;; Other events (NOT in *remap-events* or *restrict-events*) are handled normally

;;; When dispatching *restrict-events*, if the mode-stack is non-nil,
;;; the event is restricted as follows.  For each entry of the
;;; mode-stack, if the event is for the contact on the stack, or one of
;;; its descendents, it is dispatched.  When a stack-entry with
;;; :Exclusive or :Spring-Loaded MODE-TYPE is encountered, the search
;;; stops, and the event is sent to the RESTRICT-ACTION action of the
;;; mode contact with ARGS.  If there are no :Exclusive or
;;; :Spring-Loaded contacts on the stack, the event is dispatched
;;; normally.
;;;
;;; When dispatching *remap-events*, if the mode-stack is non-nil, the
;;; event is sent (re-mapped) to the first :spring-loaded contact on the
;;; mode-stack.  If there is no :spring-loaded contact, *remap-events*
;;; are handled like *restrict-events*

(defun add-mode (contact &optional (mode-type :non-exclusive) (action 'restrict) &rest args)
  "Push CONTACT with (mode-type action . args) onto the mode-stack"
  (declare (type contact contact)
	   (type mode-type mode-type)
	   (type symbol action)
	   (type list args))
  (when (and (not (eq mode-type :non-exclusive))
	     (not (sensitive-p contact)))
    (error "ADD-MODE on insensitive contact ~s" contact))
  (push (list* contact mode-type action (copy-list args))
	(display-mode-stack (contact-display contact))))

(defun delete-mode (contact)
  "Pop CONTACT (and everything above CONTACT) off the mode-stack
   Returns T when found and removed, else NIL"
  (declare (type contact contact)
	   (values boolean))
  (let* ((display (contact-display contact))
	 (mode-stack (display-mode-stack display)))
    (when mode-stack
      (do ((stack mode-stack (cdr stack)))
	  ((endp stack)
	   ;; If contact not found, check its children
	   ;; This feature utilized when un-mapping the parent of a modal contact
	   (do ((stack mode-stack (cdr stack))
		(found-p nil)
		(result nil))
	       ((endp stack)
		(when found-p
		  (setf (display-mode-stack display) result)
		  t))
	     (when (ancestor-p contact (caar stack))
	       (setq found-p t
		     result stack))))
	(when (eq contact (caar stack))
	  (setf (display-mode-stack display) (cdr stack))
	  (return t))))))

(defmacro with-mode ((contact &key (mode-type :exclusive)
			      (action 'ignore-action) args)
		     body-form &body cleanup-forms)
  "While executing BODY-FORM, user events will only be delivered to CONTACT
and its children.  Non-user events (e.g.  exposure,property-notify, etc)
will be delivered normally.  User events to other contacts will cause
the ACTION action for CONTACT's class to be invoked with ARGS.  The
primary contact method for the default ACTION, ignore-action, beeps on
*remap-events*, and ignores all others.
   
WITH-MODE executes BODY-FORM within an Unwind-Protect.  With-Mode
returns the value of its BODY-FORM, and executes CLEANUP-FORMS before
exiting. "
  (let ((local-contact (gensym)))
    `(let ((,local-contact ,contact))
       (unwind-protect
	   (progn
	     (add-mode ,local-contact ,mode-type (function ,action) ,@args)
	     ,body-form)
	 (delete-mode ,local-contact)
	 ,@cleanup-forms))))
   
(defun contact-mode (contact)
  "If contact is the descendent of a modal contact, return the modal contact, else NIL."
  (let ((modes (display-mode-stack (contact-display contact))))
    (if modes ;; No mode stack means EVERYTHING is in "on the stack"
	(do ((p contact (contact-parent p)))
	    ((null p) nil)
	  (dolist (mode modes)
	    (cond ((eq p (car mode)) 
		   (return-from contact-mode p))
		  ((eq (cadr mode) :exclusive)
		   (return nil))))))))

(defun contact-super-mode (contact)
  "If contact is the descendent of a modal contact, return the superior modal contact, else NIL."
  (let ((modes (cluei::display-mode-stack (contact-display contact))))
    (if modes ;; No mode stack means EVERYTHING is in "on the stack"
	(do ((p contact (contact-parent p)))
	    ((null p) nil)
	  (do ((mode modes (cdr mode))
	       (supermode nil))
	      ((endp mode))
	    (when (eq p (caar mode))
	      (return-from contact-super-mode supermode))
	    (unless (eq (cadar mode) :non-exclusive)
	      (setq supermode (caar mode))))))))


(defmacro with-event-mode ((contact &rest translations) &body body)
  "The given event TRANSLATIONS are defined for the CONTACT only within
the dynamic extent of the BODY. The TRANSLATIONS are processed before any
other previously-defined instance or class translations for CONTACT."
  (let ((previous-translations (gensym))
	(new-translations (gensym))
	(translation      (gensym))
	(previous         (gensym))
	(slot             (gensym)))

  `(let* ((,new-translations (list ,@translations))
	  (,slot             (slot-value (the contact ,contact) 'event-translations))
	  (,previous-translations
	   ;; Save any actions from previous instance translations for these event specs
	   (let (,previous-translations)
	     (dolist (,translation ,new-translations (nreverse ,previous-translations))
	       (when (assoc (first (parse-event-translation (first ,translation) (rest ,translation)))
			    ,slot
			    :test #'equal)
		 (push ,translation ,previous-translations))))))

     (unwind-protect
	 (progn
	   ;; Add modal translations
	   (dolist (,translation ,new-translations)
	     (apply #'add-event ,contact ,translation))
	   
	   ,@body)
       
       ;; Delete modal translations and restore any previous ones
       (dolist (,translation ,new-translations)
	 (let ((,previous (pop ,previous-translations)))
	   (if ,previous
	       (apply #'add-event ,contact ,previous)
	       (delete-event ,contact (first ,translation)))))))))




;;;-----------------------------------------------------------------------------
;;; Actions


;; Retained temporarily for compatibility purposes
(defmacro defaction (name lambda-list &body body)
  "Define an action method. THIS MACRO IS NOW OBSOLETE. Just use defmethod."
  (let (qualifier self)
    
    ;; Handle method qualifiers (:before or :after)
    (when (atom lambda-list)
      (setq qualifier   (list lambda-list)
	    lambda-list (pop body)))
    
    ;; Get the first specialized parameter in the lambda-list
    (dolist (arg lambda-list)
      (when (member arg lambda-list-keywords) (return nil))
      (when (consp arg)
	(setf self (first arg))))
    
    `(progn              
       (compiler-let (($contact$ ',self))	; Hook for call-action
	 (defmethod ,name ,@qualifier ,lambda-list
	   ,@body)))))
  

(defmacro using-event (&body body)
  `(locally
     (declare (special $event$)) 
     ,@body))

(defmacro processing-event-p ()
  `(using-event (boundp '$event$)))

(defmacro with-event (slots &body body)
  "Used within an action method to access event slots."
  
  `(using-event
     (assert
       (boundp '$event$) nil
       "WITH-EVENT used outside the dynamic extent of PROCESS-NEXT-EVENT.") 
     (with-slots ,slots (the event $event$) ,@body)))

(defmacro call-action (action &rest args)
  "Used within DEFACTION to call another action. THIS MACRO IS NOW OBSOLETE. Replace
with a direct reference to the ACTION function."
  (declare (special $contact$))
  (unless (boundp '$contact$)
    (error "CALL-ACTION used outside DEFACTION."))
  `(,action ,$contact$ ,@args))


(proclaim '(inline call-action-internal))
(defun call-action-internal (contact action)
  (if (consp action)
      (apply (car action) contact (cdr action))
      (funcall action contact)))


(defun add-before-action (display class action-name &rest args)
    "Call the action named ACTION-NAME with ARGUMENTS before every event
   on DISPLAY directed to a contact whose class is the same as
   or superclass of the action class."
    (setf (before-actions display)
	  (cons
	    (list* class action-name (copy-list args))
	    (delete-if #'(lambda (entry)
			   (and (eq class (first entry))
				(eq action-name (second entry))))
		       (before-actions display)
		       :count 1)))
    action-name)
  
(defun delete-before-action (display class action-name)
  "Remove a before event-handler from display"
  (setf (before-actions display)
	(delete-if #'(lambda (entry)
		       (and (eq class (first entry))
			    (eq action-name (second entry))))
		   (before-actions display)
		   :count 1))
  action-name)  



;;;-----------------------------------------------------------------------------
;;; BUILT-IN ACTIONS


(defmethod perform-callback ((contact basic-contact) name &rest args)  
  ;; WARNING: duplicates apply-callback code, instead of (eval (apply-callback...))
  (let ((functions (callback-p contact name)))
    (when functions
      (let ((args (copy-list args)))		;Cons Alert!!
	(catch :abort-callback
	  (do* ((functions functions         (rest functions))
		(function  (first functions) (first functions)))
	       
	       ((null (rest functions))
		;; Return value(s) of last callback function
		(apply (first function) (nconc args (rest function))))

	    (setf args (nconc args (rest function)))
	    (apply (first function) args)
	    (setf args (nbutlast args (length (rest function))))))))))

(defmethod apply-action ((contact basic-contact) function &rest args) 
  (let ((*contact* contact))
    (declare (special *contact*))
    (apply function args)))

(defmethod eval-action ((contact basic-contact)  &rest forms) 
  (let ((*contact* contact))
    (declare (special *contact*))
    (dolist (form forms)
      (eval form))))

(defmethod trace-action ((event-contact basic-contact)  &rest exceptions)
  (let (value result
	(name (contact-name event-contact)))    
    (with-event ((event-key key))
      (unless (member event-key exceptions :test #'eq)
	(format *trace-output* "~%~s on ~a:"
		event-key name)
	(dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
			     count drawable event-window focus-p format height hint-p installed-p keymap
			     keysym kind major minor mode name new-p override-redirect-p parent place
			     plist property requestor selection send-event-p state target type width
			     window x y))
	  (when (and (setf value (slot-value (the event $event$) slot-name))
		     (not (eq value event-contact)))
	    (when (typep value 'contact) (setf value (contact-name value)))
	    (setf result (nconc result (list slot-name value)))))
	(format *trace-output* "~{~<~%~20@t~1:; ~s ~s~>~^ ~}." result)))))

(defmethod describe-action ((event-contact basic-contact) &rest exceptions)
  (with-event ((event-key key))
    (unless (member event-key exceptions :test #'eq)
      (format *trace-output* "~%~s on ~a:"
	      event-key (contact-name event-contact))
      ;; Loop over slots in alphabetical order
      (dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
			   count drawable event-window focus-p format height hint-p installed-p keymap keysym
			   kind major minor mode name new-p override-redirect-p parent place plist
			   property requestor selection send-event-p state target type width window x y))
	(let ((value (slot-value (the event $event$) slot-name)))
	  (when value
	    (when (typep value 'contact) (setf value (contact-name value)))
	    (format *trace-output* "~%~5t~20s~20s" slot-name value))))
      (terpri *trace-output*))))

(defmethod ignore-action ((contact basic-contact))
  ;; Beep on *remap-events* else ignore
  (with-event (key display)
    (when (member key *remap-events* :test #'eq)
      (bell display))))

(defmethod throw-action ((contact basic-contact) tag &optional value)
  (throw tag value))


;;-----------------------------------------------------------------------------
;; EVENT-TRANSLATIONS

(defmacro defevent (class event-spec &rest actions)
  "Add an event binding to the EVENT-TRANSLATIONS property of CLASS,
   where it can be shared by all instances of CLASS."
  (let ((event-parse          (parse-event-translation event-spec actions))
	(canonical-event-spec (gensym)))
    `(progn
       ;; Generate compiler warnings for missing actions
       ;; added +symbolics by dieterm [HH 3/06/90]
       #+(or ti symbolics)
       ,@(mapcar #'(lambda (action)
			  (when (consp action) (setq action (first action)))
			  `(eval-when (compile)
			     (compiler:function-referenced
			       ',action ',(intern (format nil "DEFEVENT ~s ~s" class event-spec)))))
		      (rest event-parse))
       (let ((,canonical-event-spec ',(first event-parse)))
	
	 (setf
	   ;; Update class event translations
	   (class-name-event-translations ',class)
	   (cons
	     (cons ,canonical-event-spec ',(rest event-parse))
	     (delete ,canonical-event-spec
		     (class-name-event-translations ',class)
		     :key #'first :test #'equal :count 1))

	   ;; Flush cached class event mask, event precedence list
	   (class-name-event-mask ',class)
	   nil

	   (class-name-event-precedence-list ',class)
	   nil)))))


(defmacro undefevent (class event-spec &rest actions)
  "Remove an event binding from the EVENT-TRANSLATIONS property of CLASS."
  (declare (ignore actions))
  `(setf
       ;; Update class event translations
       (class-name-event-translations ',class)
       (delete ',(first (parse-event-translation event-spec nil))
	       (class-name-event-translations ',class)
	       :key #'first :count 1 :test #'equal)
       
       ;; Flush cached class event mask, event precedence list
       (class-name-event-mask ',class)
       nil

       (class-name-event-precedence-list ',class)
       nil))



(defmethod event-actions ((contact basic-contact) event-spec)
  "Return the list of actions for EVENT-SPEC."
  (declare (values action-list)) 

  ;; Check instance translations
  (let ((event-binding (car (parse-event-translation event-spec nil))))

    (cdr
      (or
	;; Instance translation?
	(assoc event-binding
	       (slot-value (the basic-contact contact) 'event-translations)
	       :test #'equal)

	;; Class translation?
	(dolist (class (class-name-event-precedence-list (class-name-of contact)))
	  (let ((actions (assoc event-binding
				(class-name-event-translations class)
				:test #'equal)))
	    (when actions
	      (return actions))))))))


(defmethod add-event ((contact basic-contact) event-spec &rest actions)
  "Add EVENT-SPEC and ACTIONS to the event translations for CONTACT."
  
  ;; Compute canonical event translation.
  (let ((translation  (parse-event-translation event-spec (copy-list actions))))
    (with-slots (event-mask event-translations) (the contact contact)
      
      ;; Translation for this event spec already exists?
      (let ((previous (assoc (first translation) event-translations :test #'equal)))	
	(if previous
	    ;; Yes, modify it with the new actions.
	    (setf (rest previous) (rest translation))
	    
	    ;; No, add new translation.
	    (push translation event-translations)))
      
      ;; Update window event mask, if necessary
      (when (realized-p contact)
	(let ((new-mask (event-translation-mask event-mask translation)))
	  (unless (= new-mask event-mask) 
	    (setf (window-event-mask contact) (setf event-mask new-mask)))))))
  (values))

(defmethod delete-event ((contact basic-contact) event-spec)
  "Remove any translation for EVENT-SPEC from the event translations for CONTACT."

    ;; Compute a canonical event translation for the event spec
  (let ((translation (parse-event-translation event-spec nil)))
    (with-slots (event-mask event-translations) (the contact contact) 

      ;; Remove any matching translation.
      (setf event-translations
	    (delete (first translation) event-translations
		    :key #'first :count 1 :test #'equal))

      ;; Update window event mask, if necessary
      (when (realized-p contact)		
	(let ((old-bit  (event-translation-mask 0 translation)))
	  
	  ;; Don't change event mask if some other translation sets this bit
	  (when (zerop (logand (contact-event-translations-mask contact) old-bit))
	    
	    ;; Only modify the event-mask bit for the event being deleted
	    (setf (window-event-mask contact)
		  (setf event-mask (logandc2 event-mask old-bit))))))))
  (values))





;;;-----------------------------------------------------------------------------
;;; CHECK/MATCH functions


(defun encode-button-number (button)
  (or (position button
		'#(:any :button-1 :button-2 :button-3 :button-4 :button-5))
      (xlib::x-type-error
	button 'button
	"One of :Any :button-1 :button-2 :button-3 :button-4 :button-5")))

;; Alist associating modifier keys with modifier keysyms
(defvar *meta-modifier-alist*
	'((:meta  #.(keysym :left-meta) #.(keysym :right-meta))
	  (:super #.(keysym :left-super) #.(keysym :right-super))
	  (:hyper #.(keysym :left-hyper) #.(keysym :right-hyper))))

(defconstant meta-shift 16.) ;; Where to shift meta-modifier keystates
(defconstant mod-1-shift (position :mod-1 xlib::*state-mask-vector*))
(defconstant button-0-shift (1- (position :button-1 xlib::*state-mask-vector*)))

(defun get-display-modifier-translate (display &optional update-p)
  ;; Returns a table that translates meta-modifier bits
  ;; into mod1/mod2/mod3/mod4/mod5 modifier state bits.
  (declare (type display display)
	   (type boolean update-p))
  (or (and (not update-p) (display-modifier-translate display))
      (let* ((mapping (xlib::get-display-modifier-mapping display))
	     (mod-length (length *meta-modifier-alist*))
	     (translate-length (ash 1 mod-length))
	     (display-translate (display-modifier-translate display))
	     (translate (or (and (>= (length display-translate) translate-length)
				 display-translate)
			    (make-array translate-length)))
	     (mod-vector (make-array mod-length)))
	(declare (type simple-vector translate mod-vector))
	(do* ((modifiers *meta-modifier-alist* (cdr modifiers))
	      (i 0 (1+ i))
	      (temp))
	     ((endp modifiers))
	  (setf (aref mod-vector i)
		(dolist (modifier (cdar modifiers) 0)
		  (when (setq temp (assoc modifier mapping :test #'eq))
		    (return (cdr temp))))))
	(dotimes (i translate-length)
	  (let ((mask 0))
	    (dotimes (j mod-length)
	      (when (logbitp j i)
		(setq mask (logior mask (aref mod-vector j)))))
	    (setf (aref translate i) mask)))
	(setf (display-modifier-translate display) translate))))

(proclaim '(inline translate-meta-modifiers))
(defun translate-meta-modifiers (state translate)
  ;; Translate the meta/super/hyper modifiers in state to mod-1/mod-2/mod3/mod4/mod5 modifiers.
  ;; TRANSLATE is the result from GET-DISPLAY-MODIFIER-TRANSLATE
  (logior (ldb (byte meta-shift 0) state)
	  (aref translate (ash state (- meta-shift)))))

(defun encode-clue-modifier-mask (modifiers)
  ;; Make a state-mask from modifiers
  (declare (type (or mask16 state-mask-key (member :meta :super :hyper) list) modifiers)
	   (values mask16))
  (typecase modifiers
    (fixnum (ldb (byte meta-shift 0) modifiers))
    (cons (let ((mask 0))
	    (dolist (modifier modifiers)
	      (setf mask (logior mask (encode-clue-modifier-mask modifier))))
	    mask))
    (otherwise
     (let ((temp (position modifiers (the list *meta-modifier-alist*) :key #'car :test #'eq)))
       (if temp
	   (ash 1 (+ temp meta-shift))
	 (make-state-mask modifiers))))))

(proclaim '(inline event-spec-match))
(defun event-spec-match (display state select event-state)
  (let ((translate (get-display-modifier-translate display)))
    (setq state (translate-meta-modifiers state translate)
	  select (translate-meta-modifiers select translate)))
						; The modifiers common to select and state must be DOWN and
						; The modifiers in select but not state must be UP
  (and (= (logand state select) (logand event-state select))
						; When there are modifiers in state that aren't in select
       (or (zerop (logandc2 state select))
						; At least one of them must be DOWN
	   (plusp (logand event-state (logandc2 state select)))))
						; Modifiers that aren't in state or select are ignored  
  )

#| ;; event-spec-match implements the following relationships:
 
  .-------------------------------.
  | event-state  4 4 4 4 4 4 4 4 4|
  |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  |4 4 .-------------------. 4 4 4|
  |4 4 |  Select 1 1 1 1 1 | 4 4 4|
  |4 4 | 1 1 1 1 1 1 1 1 1 | 4 4 4|
  |4 4 | 1 .-----------. 1 | 4 4 4| This would look better in color
  |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  |4 4 `---+-----------+---' 4 4 4|
  |4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
  |4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
  |4 4 4 4 | State 3 3 | 4 4 4 4 4|
  |4 4 4 4 `-----------' 4 4 4 4 4|
  |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  `-------------------------------'

 1. Modifiers in select but not state		; Must be UP in the event
 2. Modifiers both in state and select		; Must be DOWN in the event
 3. Modifiers in state but not select		; If any, at least one must be down
 4. Modifiers in neither select or state	; are ignored

|#

(defun key-check (event-key &optional char state select)
  ;; Returns the canonical form of the key (i.e. one that may speed up
  ;; the matching operation)
  (declare (ignore event-key))
  (unless (typep char '(or card16 character (member :any)))
    (error "~a is not a CHARACTER, CARD16 or :ANY." char))
  
  (let*
    ((modifiers
       (cond ((or (null state) (eq state :none))   0)
	     ((numberp state)                      state)
	     ((eq state :any)                      (setf select 0))		 		 
	     (t                                    (encode-clue-modifier-mask state))))
     (mask 
       (cond ((null select)                        (if (characterp char) 0 modifiers))
	     ((numberp select)                     select)
	     ((eq select :same)                    modifiers)
	     ((eq select :all)                     #xffff)	     	     
	     (t                                    (encode-clue-modifier-mask select)))))
    
    (list 'key-match char modifiers mask)))

(defun key-match (event spec-code spec-state spec-select)
  ;; Returns T if EVENT-SPEC matches EVENT
  (with-slots (display character state keysym) (the event event)
    (and (event-spec-match display spec-state spec-select state)
	 (cond
	   ((characterp spec-code) (eql spec-code character))
	   ((eq spec-code :any)    t)
	   (t                      (eql spec-code keysym))))))

(defun button-check (event-key &optional code state select)
  (let*
    ((click-option
       (when (consp state)
	 ;; Process state list for click type keys
	 (let* ((single (find :single-click state :test #'eq))
		(double (find :double-click state :test #'eq))
		(click  (or single double)))
	   (when click
	     (assert (not (and single double)) ()
		     "Can't specify both :SINGLE-CLICK and :DOUBLE-CLICK.")
	     (setf state (remove click state)))
	   click)))
     
     (button
       (encode-button-number (or code :any)))

     (modifiers
       (cond ((or (null state) (eq state :none))   0)
	     ((numberp state)                      state)
	     ((eq state :any)                      (setf select 0))
	     ((eq state :single-click)             (setf click-option state) 0)
	     ((eq state :double-click)             (setf click-option state) 0)
	     (t                                    (encode-clue-modifier-mask state))))
     (mask 
       (cond ((or (null select) (eq select :same)) modifiers)
	     ((numberp select)                     select)
	     ((eq select :all)                     #xffff)	     	     
	     (t                                    (encode-clue-modifier-mask select))))     
     
     (predicate
       (if (eq event-key :button-press)
	   'button-press-match
	   'button-release-match)))
    
    (list* predicate button modifiers mask (when click-option (list click-option)))))

(defun button-press-mask (button state select &optional option)
  (declare (ignore button state select))
  (if option
      #.(make-event-mask :button-press :button-release)
      #.(make-event-mask :button-press)))

(defun button-release-mask (button state select &optional option)
  (declare (ignore button state select))
  (if option
      #.(make-event-mask :button-press :button-release)
      #.(make-event-mask :button-release)))

(defun button-press-match (event button state select &optional option)
  (with-slots ((event-code code)
	       (event-state state)
	       display key plist time x y)
	      (the event event)
    (let* ((code event-code)
	   (mask (ash 1 (+ code button-0-shift))))
      (and
	(or (zerop button)			; Zero button means "any" button
	    (=  button code))
	(event-spec-match display state select
			  (logandc2 event-state mask))	; Clear state bit for current button
	(case option
	  (:single-click
	   (= (click-lookahead display 1 2 time (logior event-state mask) x y) 2))
	  (:double-click
	   (= (click-lookahead display 1 4 time (logior event-state mask) x y) 4))
	  (otherwise t))))))

(defun button-release-match (event button state select &optional option)
  (with-slots ((event-code code)
	       (event-state state)
	       key display plist time x y)
	      (the event event)
    (let* ((code event-code)
	   (mask (ash 1 (+ code button-0-shift))))
      (and
	(or (zerop button)			; Zero button means "any" button
	    (=  button code))
	(event-spec-match display state select (logandc2 event-state mask))	; Clear state bit for current button
	(case option
	  (:single-click
	   (= (click-lookahead display 2 2 time event-state x y) 2))
	  (:double-click
	   (= (click-lookahead display 2 4 time event-state x y) 4))
	  (otherwise t))))))

(defconstant all-button-mask
	     (make-state-mask :button-1 :button-2 :button-3 :button-4 :button-5))

(defun motion-check (event-key &optional state select)
  (declare (ignore event-key))
  (let*
    ((modifiers
       (cond ((or (null state) (eq state :none))   0)
	     ((numberp state)                      state)
	     ((eq state :any)                      (setf select 0) all-button-mask)	     
	     (t                                    (encode-clue-modifier-mask state))))
     (mask 
       (cond ((or (null select) (eq select :same)) modifiers)
	     ((numberp select)                     select)
	     ((eq select :all)                     #xffff)	     	     
	     (t                                    (encode-clue-modifier-mask select)))))

    (list 'motion-match modifiers mask)))

(defun motion-match (event state select)
  (with-slots (display) (the event event)
    (or (eq state :any)
	(event-spec-match display state select (slot-value (the event event) 'state)))))

(defun motion-event-mask (state select)
  (if (= all-button-mask (logand (logior state select) all-button-mask))
      #.(make-event-mask :button-motion)
      (let ((mask (logand state select all-button-mask)))
	(when (zerop mask)
	  (setq mask #.(make-event-mask :pointer-motion)))
	mask)))

(eval-when (compile) ;; motion-event-mask makes the following assumption:
  (assert (and (= (make-event-mask :button-1-motion) (make-state-mask :button-1))
	       (= (make-event-mask :button-2-motion) (make-state-mask :button-2))
	       (= (make-event-mask :button-3-motion) (make-state-mask :button-3))
	       (= (make-event-mask :button-4-motion) (make-state-mask :button-4))
	       (= (make-event-mask :button-5-motion) (make-state-mask :button-5)))
	  () "Button event-mask is shifted relative to button state-mask"))

(defun enter-leave-check (event-key &rest kinds)
  (dolist (kind kinds)
    (unless (member kind '(:ancestor :virtual :inferior :nonlinear :nonlinear-virtual))
      (error "~s isn't an enter/leave kind for ~s" kind (cons event-key kinds))))
  (list 'enter-leave-match kinds))

(defun enter-leave-match (event kinds)
  (member (slot-value (the event event) 'kind) kinds :test #'eq))

(setf (check-function :key-press) 'key-check)
(setf (check-function :key-release) 'key-check)
(setf (check-function :button-press) 'button-check)
(setf (check-function :button-release) 'button-check)
(setf (check-function :motion-notify) 'motion-check)
(setf (check-function :enter-notify) 'enter-leave-check)
(setf (check-function :leave-notify) 'enter-leave-check)

(defun key-up-check (event-key &rest parms)
  (declare (ignore event-key))
  ;; Convert (:up ...) to (:key-press ...)
  (values (apply #'key-check :key-release parms)
	   :key-release))

(setf (check-function :up) #'key-up-check)

(defun client-message-check (event-key type &rest accessors)
  (declare (ignore event-key))
  (assert (typep type 'xatom) () "~s must be an X atom." type)
  (do* ((accessors accessors          (cddr accessors))
	(function  (first accessors)  (first accessors))
	(rest      (rest accessors)   (rest accessors)))
       ((null accessors))    
    (assert rest () "No value given for ~s accessor." function))
  (values (list* 'client-message-match
		 (intern (string type) 'keyword)
		 accessors)
	  :client-message))

(defun client-message-match (event type &rest accessors)
  (with-slots ((event-type type) (event-data data) (event-display display)) event
    ;; Bind display for use in accessor functions
    (let ((*event-display* event-display))
      (declare (special *event-display*))
      (and (eq type event-type)
	   (do* ((accessors accessors          (cddr accessors))
		 (function  (first accessors)  (first accessors))
		 (value     (second accessors) (second accessors)))
		((null accessors) t)
	     (unless (equal value (funcall function event-data))
	       (return nil)))))))

(setf (check-function :client-message) #'client-message-check)


(defun wm-protocol-check (event-key &rest accessors)
  (apply 'client-message-check
	 :client-message :wm_protocols
	 'wm-message-protocol-atom event-key
	 accessors))

(setf (check-function :wm_take_focus)    #'wm-protocol-check)
(setf (check-function :wm_save_yourself) #'wm-protocol-check)
(setf (check-function :wm_delete_window) #'wm-protocol-check)

(defun timer-check (event-key timer-name)
  (declare (ignore event-key))
  (assert (symbolp timer-name) ()
	  "~a is not a timer name symbol." timer-name)
  (values
    (list 'timer-match timer-name)
    :timer))

(defun timer-match (event timer-name)
  (with-slots (name) (the event event)
    (eq timer-name name)))

(setf (check-function :timer) #'timer-check)

(defun property-check (event &optional property state)
  (declare (ignore event))
  (check-type property (or null xatom) "an XATOM")
  (check-type state    (or null (member :new-value :deleted)) ":NEW-VALUE or :DELETED")
  (cons
    'property-match
    (when property
      (cons (intern (string property) :keyword)
	    (when state
	      (cons state nil))))))

(defun property-match (event &optional property state)
  (with-slots ((event-property atom) (event-state state)) (the event event)
    (or (not property)
	(and (eq property event-property)
	     (or (not state) (eq state event-state))))))

(setf (check-function :property-notify) 'property-check)
  
;;;-----------------------------------------------------------------------------
;;; DOUBLE-CLICK events

(defun click-lookahead (display count max first-time state first-x first-y)
  (declare (type card8 count)) ;; even when the button is UP, odd when DOWN

  (let* ((multipress-verify-p (display-multipress-verify-p display))
	 (multipress-delay-limit (display-multipress-delay-limit display))
	 (timeout (/  multipress-delay-limit 1000.0))
	 (distance-limit 5))
    
    (flet ((get-result (count timeoutp)
		       ;; If the result from GET-RESULT is NIL, all lookahead events
		       ;; remain on the event queue, otherwise the events are removed,
		       ;; and the result from GET-RESULT is returned.
		       (if (or (evenp count)	; Hold events only occur on timeout
			       timeoutp)
			   count
			   0)))
      (loop
	(let*
	  ((timeout-p t)
	   (result
	     (block result
	       ;; When succeeding, we want to "eat" the events.
	       ;; When failing, we want to leave events on the event queue.
	       ;; We're careful to return non-nil from event-case only on success.
	       ;; On failure, we return-from result, which leaves events on the queue.
	       ;; the timeout-p hair is to detect the difference between failure and timeout.
	       (event-case (display :timeout timeout :force-output-p nil)
		 ((motion-notify) (x y)		; Fail when pointer moves more than a jiggle
		  (setq timeout-p nil)
		  (when (> (+ (abs (- x first-x)) (abs (- y first-y))) distance-limit)
		    (return-from result (get-result count nil))))
		 
		 ((enter-notify leave-notify) ()	; Fail when pointer moves to a new window
		  (setq timeout-p nil)
		  (return-from result (get-result count nil)))
		 
		 (button-press (time (state event-state) code)
			       (setq timeout-p nil)
			       (cond ((>= count max) (return-from result :count))
				     ((> time (+ first-time multipress-delay-limit))
				      (return-from result :timeout))
				     ((or (oddp count)
					  (not (= state (logior event-state (ash 1 (+ code button-0-shift))))))
				      (return-from result (get-result count nil)))
				     (t (let ((result (click-lookahead display (1+ count) max
								       time state first-x first-y)))
					  (if (plusp result)
					      result
					      (if (plusp (setq result (get-result count nil)))
						  (return-from result result)
						  nil ;; else fall-through returning NIL
						  ))))))
		 
		 (button-release (time (state event-state))
				 (setq timeout-p nil)
				 (cond ((>= count max) (return-from result :count))
				       ((> time (+ first-time multipress-delay-limit))
					(return-from result :timeout))
				       ((or (evenp count)
					    (not (= state event-state)))
					(return-from result (get-result count nil)))
				       (t (let ((result (click-lookahead display (1+ count) max
									 time state first-x first-y)))
					    (if (plusp result)
						result
						(if (plusp (setq result (get-result count nil)))
						    (return-from result result)
						    nil ;; else fall-through returning NIL
						    ))))))))))
	  
	  (if timeout-p
	      ;; event-case timed out
	      (if (or (zerop timeout)
		      (not multipress-verify-p))
		  
		  (return (get-result count :local-timeout))
		  
		  (progn
		    ;; Verify timeout with a server round-trip and event-queue recheck
		    (display-finish-output display)
		    (setq timeout 0)))
	      
	      ;; Else exit loop with result
	      (return (case result
			(:timeout  (get-result (1- count) :timeout))
			(:count    0)
			((nil)     0)
			(otherwise result)))))))))



;;;-----------------------------------------------------------------------------
;;; EVENT-PROCESSING

(defun process-all-events (display &optional (update-state-p t))
  "Repeatedly flush output and process resulting events until event queue is empty."
  (loop
    ;; Flush output buffer and wait for resulting events
    (display-finish-output display)

    ;; Any events left to process?
    (if (event-listen display 0)

	;; Yes, process remaining event queue
	(loop
	  (unless (process-next-event display 0 update-state-p) (return)))

	;; No
	(return))))

#-pcl
(defun process-next-event (display &optional timeout (update-state-p t))
  "Process one event. Call UPDATE-STATE iff UPDATE-STATE-P is true. "
  (declare (type display display)
	   (type (or null number) timeout)
	   (type boolean update-state-p)
	   (values boolean))

  ;; Ensure consistent contact states
  (when update-state-p (update-state display))

  (let*
    (;; Process any timers that have expired
     (interval-until-next-timer  (execute-timers display))
     
     ;; Compute true timeout
     (wait-for-timer-p           (when (or (null timeout)
					   (and interval-until-next-timer
						(< interval-until-next-timer timeout)))				      
				   interval-until-next-timer))
     
     (event                      (allocate-event))
     (result                     nil))

    (declare (type event event))
    
    (setf (slot-value (the event event) 'display) display)
    
    (macrolet ((set-event (&rest parameters)
		 `(progn ,@(mapcar #'(lambda (parm)
				       `(setf (slot-value (the event event) ',parm) ,parm))
				   parameters)))
	       (dispatch (contact)
		  `(progn
		     (dispatch-event event event-key send-event-p sequence ,contact)
		     t)))
      ;; Wait for an event, copy info into the EVENT structure then call DISPATCH-EVENT
      (setf
	result
	(or
	  (xlib:event-cond (display :timeout (or wait-for-timer-p timeout)
				    :force-output-p t
				    :discard-p t)
	    ((:key-press :key-release :button-press :button-release)
	     (code time root window child root-x root-y x y
		   state same-screen-p event-key sequence send-event-p) t
	     (set-event code time root window child root-x root-y x y
			state same-screen-p)
	     (dispatch window))
	    
	    (:motion-notify
	      (hint-p time root window child root-x root-y x y
		      state same-screen-p event-key sequence send-event-p) t
	      (set-event hint-p time root window child root-x root-y x y
			 state same-screen-p)
	      (dispatch window))
	    
	    ((:enter-notify :leave-notify)
	     (kind time root window child root-x root-y x y
		   state mode focus-p same-screen-p event-key sequence send-event-p) t
	     (set-event kind time root window child root-x root-y x y
			state mode focus-p same-screen-p)
	     (dispatch window))
	    
	    ((:focus-in :focus-out)
	     (kind window mode event-key sequence send-event-p) t
	     (set-event kind window mode)
	     (dispatch window))
	    
	    (:exposure
	      (window x y width height count event-key sequence send-event-p) t
	      (set-event window x y width height count)
	      (dispatch window))
	    
	    (:graphics-exposure
	      (drawable x y width height count major minor event-key sequence send-event-p) t
	      (set-event drawable x y width height count major minor)
	      (dispatch drawable))
	    
	    (:no-exposure
	      (drawable major minor event-key sequence send-event-p) t
	      (set-event drawable major minor)
	      (dispatch drawable))
	    
	    (:visibility-notify
	      (window state event-key sequence send-event-p) t
	      (set-event window state)
	      (dispatch window))
	    
	    (:create-notify
	      (parent window x y width height border-width
		      override-redirect-p event-key sequence send-event-p) t
	      (set-event parent window x y width height border-width
			 override-redirect-p)
	      (dispatch parent))
	    
	    (:destroy-notify
	      (event-window window event-key sequence send-event-p) t
	      (set-event event-window window)
	      (dispatch event-window))
	    
	    (:unmap-notify
	      (event-window window configure-p event-key sequence send-event-p) t
	      (set-event event-window window configure-p)
	      (dispatch event-window))
	    
	    (:map-notify
	      (event-window window override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window override-redirect-p)
	      (dispatch event-window))
	    
	    (:map-request
	      (parent window event-key sequence send-event-p) t
	      (set-event parent window)
	      (dispatch parent))
	    
	    (:reparent-notify
	      (event-window window parent x y override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window parent x y override-redirect-p)
	      (dispatch event-window))
	    
	    (:configure-notify
	      (event-window window above-sibling x y width height border-width
			    override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window above-sibling x y width height
			 border-width override-redirect-p)
	      (dispatch event-window))
	    
	    (:configure-request
	      (parent window above-sibling x y width height border-width event-key sequence send-event-p) t
	      (set-event parent window above-sibling x y width height border-width)
	      (dispatch parent))
	    
	    (:gravity-notify
	      (event-window window x y event-key sequence send-event-p) t
	      (set-event event-window window x y)
	      (dispatch event-window))
	    
	    (:resize-request
	      (window width height event-key sequence send-event-p) t
	      (set-event window width height)
	      (dispatch window))
	    
	    (:circulate-notify
	      (event-window window parent place event-key sequence send-event-p) t
	      (set-event event-window window parent place)
	      (dispatch event-window))
	    
	    (:circulate-request
	      (parent window place event-key sequence send-event-p) t
	      (set-event parent window place)
	      (dispatch parent))
	    
	    (:property-notify
	      (window atom time state event-key sequence send-event-p) t
	      (set-event window atom time state)
	      (dispatch window))
	    
	    (:selection-clear
	      (time window selection event-key sequence send-event-p) t
	      (set-event time window selection)
	      (dispatch window))
	    
	    (:selection-request
	      (time window requestor selection target property event-key sequence send-event-p) t
	      (set-event time window requestor selection target property)
	      (dispatch window))
	    
	    (:selection-notify
	      (time window selection target property event-key sequence send-event-p) t
	      (set-event time window selection target property)
	      (dispatch window))
	    
	    (:colormap-notify
	      (window colormap new-p installed-p event-key sequence send-event-p) t
	      (set-event window colormap new-p installed-p)
	      (dispatch window))
	    
	    (:client-message
	      (format window type data event-key sequence send-event-p) t
	      (set-event format window type data)
	      (dispatch window))
	    
	    (:keymap-notify			; Special case
	      (keymap event-key send-event-p) t
	      (set-event keymap)		; keymap-notify doesn't have an associated window.
	      (let ((sequence 0))
		(dispatch (display-root display))))	; Send keymap-notify events to the root.
	    
	    (:mapping-notify			; Special case
	      (request start count) t
	      (mapping-notify display request start count)
	      (when (eq request :modifier)	; Update the modifier mapping translate table
		(get-display-modifier-translate display :update))
	      t))

	  ;; No event read -- return true (i.e. no timeout) if we now have a timer ready
	  (when wait-for-timer-p t))))
    
    ;; We could add an unwind protect to ensure that the event is always
    ;; deallocated (process-next-event is sometimes thrown out of).
    ;; However, we judge that an unwind-protect all the time is more
    ;; expensive than garbage collecting an event structure some of the
    ;; time.
    (deallocate-event event)
    
    result))

#+pcl
(progn

(defun process-next-event (display &optional timeout (update-state-p t))
  "Process one event. Call UPDATE-STATE iff UPDATE-STATE-P is true. "
  (declare (type display display)
	   (type (or null number) timeout)
	   (type boolean update-state-p)
	   (values boolean))

  ;; Ensure consistent contact states
  (when update-state-p (update-state display))

  (let*
    (;; Process any timers that have expired
     (interval-until-next-timer  (execute-timers display))
     
     ;; Compute true timeout
     (wait-for-timer-p           (when (or (null timeout)
					   (and interval-until-next-timer
						(< interval-until-next-timer timeout)))				      
				   interval-until-next-timer))
     
     (event                      (allocate-event))
     (result                     nil))

    (declare (type event event))
    
    (setf (slot-value (the event event) 'display) display)

    (setf result
	  (or (set-event-and-dispatch event display (or wait-for-timer-p timeout))
	      ;; No event read -- return true (i.e. no timeout) if we now have a timer ready
	      (when wait-for-timer-p t)))
    
    ;; We could add an unwind protect to ensure that the event is always
    ;; deallocated (process-next-event is sometimes thrown out of).
    ;; However, we judge that an unwind-protect all the time is more
    ;; expensive than garbage collecting an event structure some of the
    ;; time.
    (deallocate-event event)
    
    result))

(defmethod set-event-and-dispatch ((event event) display timeout)
    (macrolet ((set-event (&rest parameters)
		 `(progn ,@(mapcar #'(lambda (parm)
				       `(setf (slot-value (the event event) ',parm) ,parm))
				   parameters)))
	       (dispatch (contact)
		  `(progn
		     (dispatch-event event event-key send-event-p sequence ,contact)
		     t)))
      ;; Wait for an event, copy info into the EVENT structure then call DISPATCH-EVENT
	  (xlib:event-cond (display :timeout timeout
				    :force-output-p t
				    :discard-p t)
	    ((:key-press :key-release :button-press :button-release)
	     (code time root window child root-x root-y x y
		   state same-screen-p event-key sequence send-event-p) t
	     (set-event code time root window child root-x root-y x y
			state same-screen-p)
	     (dispatch window))
	    
	    (:motion-notify
	      (hint-p time root window child root-x root-y x y
		      state same-screen-p event-key sequence send-event-p) t
	      (set-event hint-p time root window child root-x root-y x y
			 state same-screen-p)
	      (dispatch window))
	    
	    ((:enter-notify :leave-notify)
	     (kind time root window child root-x root-y x y
		   state mode focus-p same-screen-p event-key sequence send-event-p) t
	     (set-event kind time root window child root-x root-y x y
			state mode focus-p same-screen-p)
	     (dispatch window))
	    
	    ((:focus-in :focus-out)
	     (kind window mode event-key sequence send-event-p) t
	     (set-event kind window mode)
	     (dispatch window))
	    
	    (:exposure
	      (window x y width height count event-key sequence send-event-p) t
	      (set-event window x y width height count)
	      (dispatch window))
	    
	    (:graphics-exposure
	      (drawable x y width height count major minor event-key sequence send-event-p) t
	      (set-event drawable x y width height count major minor)
	      (dispatch drawable))
	    
	    (:no-exposure
	      (drawable major minor event-key sequence send-event-p) t
	      (set-event drawable major minor)
	      (dispatch drawable))
	    
	    (:visibility-notify
	      (window state event-key sequence send-event-p) t
	      (set-event window state)
	      (dispatch window))
	    
	    (:create-notify
	      (parent window x y width height border-width
		      override-redirect-p event-key sequence send-event-p) t
	      (set-event parent window x y width height border-width
			 override-redirect-p)
	      (dispatch parent))
	    
	    (:destroy-notify
	      (event-window window event-key sequence send-event-p) t
	      (set-event event-window window)
	      (dispatch event-window))
	    
	    (:unmap-notify
	      (event-window window configure-p event-key sequence send-event-p) t
	      (set-event event-window window configure-p)
	      (dispatch event-window))
	    
	    (:map-notify
	      (event-window window override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window override-redirect-p)
	      (dispatch event-window))
	    
	    (:map-request
	      (parent window event-key sequence send-event-p) t
	      (set-event parent window)
	      (dispatch parent))
	    
	    (:reparent-notify
	      (event-window window parent x y override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window parent x y override-redirect-p)
	      (dispatch event-window))
	    
	    (:configure-notify
	      (event-window window above-sibling x y width height border-width
			    override-redirect-p event-key sequence send-event-p) t
	      (set-event event-window window above-sibling x y width height
			 border-width override-redirect-p)
	      (dispatch event-window))
	    
	    (:configure-request
	      (parent window above-sibling x y width height border-width event-key sequence send-event-p) t
	      (set-event parent window above-sibling x y width height border-width)
	      (dispatch parent))
	    
	    (:gravity-notify
	      (event-window window x y event-key sequence send-event-p) t
	      (set-event event-window window x y)
	      (dispatch event-window))
	    
	    (:resize-request
	      (window width height event-key sequence send-event-p) t
	      (set-event window width height)
	      (dispatch window))
	    
	    (:circulate-notify
	      (event-window window parent place event-key sequence send-event-p) t
	      (set-event event-window window parent place)
	      (dispatch event-window))
	    
	    (:circulate-request
	      (parent window place event-key sequence send-event-p) t
	      (set-event parent window place)
	      (dispatch parent))
	    
	    (:property-notify
	      (window atom time state event-key sequence send-event-p) t
	      (set-event window atom time state)
	      (dispatch window))
	    
	    (:selection-clear
	      (time window selection event-key sequence send-event-p) t
	      (set-event time window selection)
	      (dispatch window))
	    
	    (:selection-request
	      (time window requestor selection target property event-key sequence send-event-p) t
	      (set-event time window requestor selection target property)
	      (dispatch window))
	    
	    (:selection-notify
	      (time window selection target property event-key sequence send-event-p) t
	      (set-event time window selection target property)
	      (dispatch window))
	    
	    (:colormap-notify
	      (window colormap new-p installed-p event-key sequence send-event-p) t
	      (set-event window colormap new-p installed-p)
	      (dispatch window))
	    
	    (:client-message
	      (format window type data event-key sequence send-event-p) t
	      (set-event format window type data)
	      (dispatch window))
	    
	    (:keymap-notify			; Special case
	      (keymap event-key send-event-p) t
	      (set-event keymap)		; keymap-notify doesn't have an associated window.
	      (let ((sequence 0))
		(dispatch (display-root display))))	; Send keymap-notify events to the root.
	    
	    (:mapping-notify			; Special case
	      (request start count) t
	      (mapping-notify display request start count)
	      (when (eq request :modifier)	; Update the modifier mapping translate table
		(get-display-modifier-translate display :update))
	      t))
)   )

)

(defmethod dispatch-event ((event event) event-key send-event-p sequence (contact contact))
  ;; Called from PROCESS-NEXT-EVENT to filter events and call event handlers.
  (declare (type event   event)
	   (type keyword event-key)
	   (type boolean send-event-p)
	   (type card16  sequence)
	   (type contact contact))
  (declare (optimize speed (safety 0) (space 0)))
  (declare (inline sensitive-p))
  
  (with-slots ((event_key key)
	       (event-sequence sequence)
	       (event-send-event-p send-event-p)
	       (event-contact contact)) (the event event)
    (setf event_key event-key
	  event-send-event-p send-event-p
	  event-sequence sequence
	  event-contact contact))

  (let ((class (class-name-of contact)))
    ;;
    ;; Check for non-contact event drawables.
    ;;
    (if (or (eq class 'window) (eq class 'pixmap))
	
	(handle-event (display-root (drawable-display contact)) event)
	
	(if (destroyed-p contact)
	    
	    ;; Destroyed-contact!
	    (when (eq event-key :destroy-notify)
	      (destroy-finish contact))
	    
	    ;; Bind event for reference within with-event forms
	    (let ((display (slot-value contact 'display))
		  ($event$ event))
	      (declare (special $event$))
	      
	      ;;
	      ;; Do key translation
	      ;;
	      (when (or (eq event-key :key-press)
			(eq event-key :key-release))
		(with-slots (keysym character code state) (the event event)
		  (let ((keysym-index (default-keysym-index display code state)))
		    (setf keysym (keycode->keysym display code keysym-index)
			  character (keycode->character display code state :keysym-index keysym-index)))))
	      ;;
	      ;; Call the before event handlers
	      ;;
	      (dolist (before-action (before-actions display))
		(when (subtypep class (first before-action))
		  (call-action-internal contact (rest before-action))))
	      ;;
	      ;; Handle insensitive contacts
	      ;;
	      (when (and (member event-key *sensitive-events* :test #'EQ)
			 (not (sensitive-p contact)))
		(return-from dispatch-event nil))
	      
	      ;;
	      ;; Handle modes 
	      ;;
	      (let ((modes (display-mode-stack display)))
		(when (and modes (not (contact-mode contact)))
		  (when
		    (or (member event-key *restrict-events* :test #'eq)
			(and (member event-key *remap-events* :test #'eq)
			     (dolist (mode modes t) ;; Search for first :spring-loaded mode
			       (when (eq (second mode) :spring-loaded)
				 (format t "~%Remapping ~s from ~s to ~s" event-key contact (first mode)) ;; *** DEBUG ***
				 (setq contact (first mode)) ;; Remap contact
				 (return nil)))))
		    ;; Call mode action on for first :exclusive or :spring-loaded mode
		    (dolist (mode modes)
		      (unless (eq (second mode) :non-exclusive)
			(call-action-internal (first mode) (cddr mode))
			;; quit
			(return-from dispatch-event nil))))))
	      
	      ;; 
	      ;; Handle event compression
	      ;;
	      (with-slots ((contact-compress-motion compress-motion)
			   (contact-compress-exposures compress-exposures))
			  (the contact contact)
		
		(case event-key
		  (:exposure			; Check for exposure compression
		   (when (and (eq contact-compress-exposures :on)
			      (plusp (slot-value event 'count)))
		     ;; Accumulate total exposed area into one event
		     (let* ((exposed-min-x (slot-value event 'x))
			    (exposed-min-y (slot-value event 'y))
			    (exposed-max-x (+ exposed-min-x (slot-value event 'width)))
			    (exposed-max-y (+ exposed-min-y (slot-value event 'height)))
			    (compressed    0))
		       
		       (event-case (display :force-output-p nil :discard-p t)
			 ;; Assert: We can discard all events up to 0-count :exposure
			 ;; because the protocol says that no non-exposure events can intervene.
			 (:exposure (x y width height count)
				    (setf exposed-min-x (min x exposed-min-x) 
					  exposed-min-y (min y exposed-min-y)
					  exposed-max-x (max (+ x width)  exposed-max-x)
					  exposed-max-y (max (+ y height) exposed-max-y))
				    (incf compressed)
				    (zerop count)))

		       (setf (slot-value event 'x)      exposed-min-x
			     (slot-value event 'y)      exposed-min-y
			     (slot-value event 'width)  (- exposed-max-x exposed-min-x)
			     (slot-value event 'height) (- exposed-max-y exposed-min-y)
			     (slot-value event 'count)  0)

		       ;; Ensure all of exposed region reported has been cleared.
		       (when (> compressed 1)
			 (clear-area
			   contact
			   :x      (slot-value event 'x)      
			   :y      (slot-value event 'y)      
			   :width  (slot-value event 'width)  
			   :height (slot-value event 'height))))))
		  
		  (:motion-notify		; Check for motion compression
		   (when (eq contact-compress-motion :on)
		     (let ((count 0))
		       
		       ;; Count consecutive :motion-notify's currently in queue
		       (event-case (display :force-output-p nil :peek-p t :timeout 0)
			 (:motion-notify (window)
					 (not (and (eq window contact) (incf count))))
			 (otherwise ()   t))
		       
		       (when (plusp count) 
			 ;; Remove all but last and quit immediately
			 (do () ((zerop (decf count)))
			   (event-case (display :timeout 0)
			     (otherwise ()   t)))
			 (return-from dispatch-event nil)))))))
	      ;;
	      ;; Handle event translations
	      ;;
	      (handle-event contact event))))))

(defmethod handle-event ((contact basic-contact) (event event))
  "Do event/callback translation based on the event-translations slot."
  (declare (type contact contact)
	   (type event event))
  ;;
  ;; Handle universal events
  ;;
  (when (eq :exposure (slot-value (the event event) 'key))
    (with-slots (x y width height) (the event event)
      (display contact x y width height)))

;; The following "universal event" is obsolete -- use shells for top-level windows
;    (:configure-notify
;     ;; A contact's x/y/width/height/border-width get updated immediately when
;     ;; changing geometry.  Top-level windows however, have their geometry
;     ;; arbitrated by the window-manager.  It probably doesn't make sense for
;     ;; a non-top-level contact to select structure-notify.  Because CLUE allows
;     ;; any contact to be top-level, CLUE automatically selects structure-notify
;     ;; for top-level contracts, and we set the size/position here.
;     ;; If non-top-level contacts select structure-notify, we let them handle it
;     ;; themselves.
;     ;;
;     ;; This is inadequate.  The geometry manager for the
;     ;; root should be used instead, waiting for the configure-notify,
;     ;; and returning an appropriate successs-p parameter.
;     ;;
;     (with-slots (x y width height border-width window) (the event event)
;       (when (and (eq window contact) (top-level-p contact))
;	 (without-requests contact
;	   (move contact x y)
;	   (resize contact width height border-width)))))
    
  ;;
  ;; Translate event and perform contact actions
  ;;
  (dolist (action (translate-event contact event))
    (call-action-internal contact action))
  
  t)

(defmethod translate-event ((contact basic-contact) (event event))
  "Returns the actions for the first event-translation matching EVENT"
  (declare (type basic-contact contact)
	   (type event         event))
  (labels ((find-translation (event event-key translations)
	     (dolist (event-binding translations)
	       (let ((event-spec (car event-binding)))
		 (when (if (atom event-spec)
			   ;; Simple EQ test when event spec is an atom
			   (eq event-key event-spec)
			 ;; When event spec is a list, and
			 ;; the car of the list is EQ to the event, and
			 ;; the matcher function returns T
			 (and (eq event-key (car event-spec))
			      (apply (cadr event-spec) event (cddr event-spec))))
		   (return event-binding))))))

    (let ((key (slot-value (the event event) 'key)))
      (cdr
	(or
	  ;; Instance translations
	  (find-translation event key (slot-value (the basic-contact contact) 'event-translations))

	  ;; Class translations 
	  (dolist (class (class-name-event-precedence-list (class-name-of contact)))
	    (let ((translation (find-translation event key (class-name-event-translations class))))
	      (when translation (return translation)))))))))

(defmethod translate-key ((contact contact) (event event))
  ;; Find a translation for :key-press event EVENT which
  ;; was originally sent to CONTACT.
  (let* ((parent (contact-parent contact))
	 (siblings (and parent (composite-children parent)))
	 actions)
    (or ;; Check for handled by a sibling
      (dolist (sibling siblings)
	(unless (eq sibling contact)
	  (when (setq actions (translate-event sibling event))
	    (setf (slot-value (the event event) 'contact) sibling)
	    (dolist (action actions t)
	      (call-action-internal sibling action))
	    (return t))))
      ;; If not handled by a sibling of contact, check the parent
      (when (and parent
		 (setq actions (translate-key parent event)))
	(setf (slot-value (the event event) 'contact) parent)
	(dolist (action actions t)
	  (call-action-internal parent action)))
      ;; Not handled by parent, recurse up to the parent
      (translate-key parent contact))))


;;-----------------------------------------------------------------------------
;; TIMERS

(defstruct timer
  name
  time
  interval
  contact
  data)

(defun add-timer (contact name interval &optional data)
  "Send a :timer event to CONTACT every INTERVAL seconds passing DATA
 The timer will be named NAME.  The event is passed DATA NAME CONTACT and DISPLAY"
  ;; Timers are automatically removed when CONTACT is destroyed
  (declare (type contact contact)
	   (type number interval) ;; in seconds
	   (values timer))
  (delete-timer contact name)
  (insert-timer (make-timer
		  :name name
		  :interval (* interval internal-time-units-per-second)
		  :contact contact
		  :data data))
  name)

;; Internal function
(defun insert-timer (timer)
  ;; Insert timer into its timer-queue
  (let* ((display  (contact-display (timer-contact timer)))
	 (queue    (timer-queue display))
	 (interval (timer-interval timer))
	 (time     (+ interval (get-internal-real-time))))
    
    (setf (timer-time timer) time)
    
    ;; Insert in order of execution (youngest first)
    (if (or (null queue) (< time (timer-time (first queue))))
	
	(push timer (timer-queue display))
	
	(loop
	  (when (or (null (cdr queue))
		    (< time (timer-time (cadr queue))))
	    (return (setf (cdr queue) (cons timer (cdr queue)))))
	  (pop queue)))
    
    timer))

(defun delete-timer (contact &optional timer-name)
  "Remove timer named TIMER-NAME from CONTACT
 If timer-name is NIL, remove ALL timers from CONTACT.
 Returns NIL when timer not found, else T."
  (let* ((display (contact-display contact))
	 (timer-queue (timer-queue display))
	 (deletedp nil))
    (dolist (timer timer-queue)
      (when (and (eq (timer-contact timer) contact)
		 (or (null timer-name)
		     (equal (timer-name timer) timer-name)))
	(setq deletedp t)
	(setf (timer-queue display)
	      (delete timer timer-queue :test #'eq :count 1))
	(when timer-name
	  (return t))))
    ;; Return T when timers deleted
    deletedp))


(defun execute-timers (display)
  "Execute all timers whose time has come, returning the time (in seconds)
 before the next timer executes for DISPLAY"
  (loop
    (let ((next-timer (car (timer-queue display))))

      (unless next-timer
	;; No timers active
	(return nil))

      (let ((next-time  (timer-time next-timer)))
	(when (> next-time (get-internal-real-time))
	  ;; Return time interval before next timer fires
	  (return
	    (/ (- next-time (get-internal-real-time))
	       #.(float internal-time-units-per-second)))))

      ;; Reinsert timer for next firing
      (pop (timer-queue display)) ;; Warning: If an abort happens here, There's a short
      (insert-timer next-timer)   ;;          interval where a timer may be lost.

      ;; Dispatch a :timer event
      (let ((event (allocate-event)))
	(with-slots ((event-display display)
		     name data) (the event event)
	  (setf event-display display
		name (timer-name next-timer)
		data (timer-data next-timer)))
	(dispatch-event event :timer nil 0 (timer-contact next-timer))
	(deallocate-event event)))))


;;;-----------------------------------------------------------------------------
;;; Utility functions

(defun describe-event-translations (contact &optional (stream *standard-output*))
  "Print the event translations for CONTACT. If contact is a contact class name, 
print the event translations for that contact class."
  (flet ((print-event (class event stream)
	   (format stream "~%From ~20a ~s" class (car event))
	   (dolist (action (cdr event))
	     (write-char #\space stream)
	     (prin1 action stream))))
    
    (let ((translations (when (typep contact 'basic-contact)
			  (slot-value (the basic-contact contact) 'event-translations))))
      
      ;; Print instance event translations for the contact
      (dolist (event translations)
	(print-event contact event stream))
      
      ;; Print event-translations for the contact's superclasses
      (dolist (class (class-name-event-precedence-list
		       (if (symbolp contact) contact (class-name-of contact))))
	(dolist (event (class-name-event-translations class))
	  (unless (assoc (car event) translations :test #'equal)
	    (print-event class event stream)
	    (push event translations)))))))
