;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-

(in-package :xtest :use '(:xlib :lisp))

(defstruct event
  key					   ; Event key
  display				   ; Display event was reported to
  ;; The following are from the CLX event
  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
  send-event-p
  )

(defun process-input (display &optional timeout)
  "Process one event"
  (declare (type display display)		; The display (from initialize-clue)
	   (type (or null number) timeout)	; optional timeout in seconds
	   (values (or null character)))        ; Returns NIL only if timeout exceeded
  (let ((event (make-event)))
    (setf (event-display event) display)
    (macrolet ((set-event (&rest parameters)
		 `(progn ,@(mapcar #'(lambda (parm)
				       `(setf (,(intern (concatenate 'string
							  (string 'event-)
							  (string parm)))
					       event) ,parm))
				   parameters)))
	       (dispatch (contact)
		  `(dispatch-event event event-key send-event-p ,contact)))

      (let ((result
	      (xlib:event-case (display :timeout timeout :force-output-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 send-event-p)
		 (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 send-event-p)
		  (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 send-event-p)
		 (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 send-event-p)
		 (set-event kind window mode)
		 (dispatch window))
		
		(:keymap-notify
		  (window keymap event-key send-event-p)
		  (set-event window keymap)
		  (dispatch window))
		
		(:exposure
		  (window x y width height count event-key send-event-p)
		  (set-event window x y width height count)
		  (dispatch window))
		
		(:graphics-exposure
		  (drawable x y width height count major minor event-key send-event-p)
		  (set-event drawable x y width height count major minor)
		  (dispatch drawable))
		
		(:no-exposure
		  (drawable major minor event-key send-event-p)
		  (set-event drawable major minor)
		  (dispatch drawable))
		
		(:visibility-notify
		  (window state event-key send-event-p)
		  (set-event window state)
		  (dispatch window))
		
		(:create-notify
		  (parent window x y width height border-width
			  override-redirect-p event-key send-event-p)
		  (set-event parent window x y width height border-width
			     override-redirect-p)
		  (dispatch parent))
		
		(:destroy-notify
		  (event-window window event-key send-event-p)
		  (set-event event-window window)
		  (dispatch event-window))
		
		(:unmap-notify
		  (event-window window configure-p event-key send-event-p)
		  (set-event event-window window configure-p)
		  (dispatch event-window))
		
		(:map-notify
		  (event-window window override-redirect-p event-key send-event-p)
		  (set-event event-window window override-redirect-p)
		  (dispatch event-window))
		
		(:map-request
		  (parent window event-key send-event-p)
		  (set-event parent window)
		  (dispatch parent))
		
		(:reparent-notify
		  (event-window window parent x y override-redirect-p event-key send-event-p)
		  (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 send-event-p)
		  (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 send-event-p)
		  (set-event parent window above-sibling x y width height border-width)
		  (dispatch parent))
		
		(:gravity-notify
		  (event-window window x y event-key send-event-p)
		  (set-event event-window window x y)
		  (dispatch event-window))
		
		(:resize-request
		  (window width height event-key send-event-p)
		  (set-event window width height)
		  (dispatch window))
		
		(:circulate-notify
		  (event-window window parent place event-key send-event-p)
		  (set-event event-window window parent place)
		  (dispatch event-window))
		
		(:circulate-request
		  (parent window place event-key send-event-p)
		  (set-event parent window place)
		  (dispatch parent))
		
		(:property-notify
		  (window atom time state event-key send-event-p)
		  (set-event window atom time state)
		  (dispatch window))
		
		(:selection-clear
		  (time window selection event-key send-event-p)
		  (set-event time window selection)
		  (dispatch window))
		
		(:selection-request
		  (time window requestor selection target property event-key send-event-p)
		  (set-event time window requestor selection target property)
		  (dispatch window))
		
		(:selection-notify
		  (time window selection target property event-key send-event-p)
		  (set-event time window selection target property)
		  (dispatch window))
		
		(:colormap-notify
		  (window colormap new-p installed-p event-key send-event-p)
		  (set-event window colormap new-p installed-p)
		  (dispatch window))
		
		(:client-message
		  (format window type data event-key send-event-p)
		  (set-event format window type data)
		  (dispatch window))
		
		(:mapping-notify
		  (request start count)
		  (mapping-notify display request start count)) ;; Special case
		)))
	(and result t)))))

(defun event-case-test (display)
  ;; Tests universality of display, event-key, event-code, send-event-p and event-window
  (event-case (display)
    ((key-press key-release button-press button-release motion-notify
      enter-notify leave-notify focus-in focus-out keymap-notify
      exposure graphics-exposure no-exposure visibility-notify
      create-notify destroy-notify unmap-notify map-notify map-request
      reparent-notify configure-notify gravity-notify resize-request
      configure-request circulate-notify circulate-request property-notify
      selection-clear selection-request selection-notify colormap-notify client-message)
     (display event-key event-code send-event-p event-window)
     (print (list display event-key event-code send-event-p event-window)))
    (mapping-notify ;; mapping-notify doesn't have event-window
      (display event-key event-code send-event-p)
      (print (list display event-key event-code send-event-p)))
    ))