;;; Copyright (C) 1991 Christopher J. Love
;;; Copyright (C) 1994 Chuck Thompson
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;; event.el - provide general event handling.  Originally written by
;;;	       Susan Hinrich, modified by Alan Carroll and Chris Love
;;;	       Ported to Lucid Emacs and modified more by Chuck Thompson

(require 'cl)

(provide 'event)

(defvar event::functions nil "List of event/handler")

(defun install-event (event)
  (if (null (assq event event::functions))
      (push (cons event nil) event::functions)))

(defun remove-event (event)
  (setq event::functions (alist-delete event event::functions)))

(defun push-event (event handler)
  (let
    ((elist (assq event event::functions)))
    (when (consp elist)
	  (setcdr elist (cons handler (cdr elist))))))

(defun pop-event (event)
  (let
    ((elist (assq event event::functions)))
    (when (consp elist)
	  (prog1
	      (cadr elist)
	    (setcdr elist (cddr elist))))))

(defun ignore-event (event)
  (push-event event t))	;install a non-function

(defun resume-event (event)
  (let
    ((h (pop-event event)))
    (when (and h (functionp h))		;not an ignore! put it back
	  (push-event event h))))

(defun event::handler ()
  (let*
      (
       (event::type (aref epoch::event 0))
       (event::screen (aref epoch::event 2))
       (event::value (aref epoch::event 1))
       (callback (cadr (assq event::type event::functions)))
       )
    (when (and callback (functionp callback))
	  (unwind-protect
	      ;; BODY
	      (funcall callback event::type event::value event::screen)
	    ;; CLEAN-UP
	    (when (null epoch::event-handler) ;something got hosed
		  (setq epoch::event-handler 'event::handler) ;reinstall me
		  (ignore-event event::type)))))	;inhibit the handler
  (setq *last-event* epoch::event))

(setq epoch::event-handler 'event::handler)
(defvar *event-status-buffer* nil "Buffer for displaying event status")

(defun event-handler-name (event-stack)
  (let ((depth 0))
    (while (and event-stack (not (functionp (car event-stack))))
      (setq event-stack (cdr event-stack))
      (incf depth))
    (let ((handler (car event-stack)))
      (cons
       (cond
	((null handler) "-None-")
	((symbolp handler) (symbol-name handler))
	((listp handler) "+Anonymous+")
	(t "? Unknown ?"))
       depth))))

(defun update-event-status-buffer ()
  (when
   (or (null *event-status-buffer*)
       (null (buffer-name *event-status-buffer*)))
   (setq *event-status-buffer* (get-buffer-create " *Event Status*")))
  (save-excursion
    (set-buffer *event-status-buffer*)
    (setq buffer-read-only nil)
    (erase-buffer)
    (epoch::clear-zones)
    (insert "State  " (flush-left "Event" 20) "Handler\n")
    (epoch::add-zone 1 6 motion::style)
    (epoch::add-zone 8 14 motion::style)
    (epoch::add-zone 28 35 motion::style)

    (dolist (ev event::functions)
	    (let
		((handler (cadr ev))
		 state
		 (depth (length (cdr ev)))
		 (handler-state (event-handler-name (cdr ev))))
	      (cond
	       ((null (cdr ev))  (setq state "U"))
	       ((functionp handler)
		(setq state (if (< depth 2) "H" (format "H %2d" depth))))
	       (t
		(setq state
		      (if (< (cdr handler-state) 2)
			  "I"
			(format "I %2d" (cdr handler-state))))))
	      (insert
	       (flush-left state 7)
	       (flush-left (symbol-name (car ev)) 20)
	       (car handler-state)
	       "\n")))
    (insert
     "\nEvent dispatcher: " (prin1-to-string epoch::event-handler) "\n")
    (set-buffer-modified-p nil)
    (setq buffer-read-only t)))

(defun display-event-status ()
  (interactive)
  (update-event-status-buffer)
  (display-buffer *event-status-buffer*))

;;; install now so 
(install-event 'map)
(install-event 'resize)
(install-event 'move)
(install-event 'client-message)
(install-event 'focus)
(install-event 'property-change)
(install-event 'button)
(install-event 'motion)


;;; Handler that maintains on-event-do lists
(defvar on-event::do-list (list '(map) '(unmap) '(move) '(resize))
"Alist of event, screen/action lists")

(defun on-event::handler (type value screen)
  "Handle events that have one-shot actions. Types are controlled by the
variable on-event::do-list, which is an alist of event types, with the
value an alist of screens and actions."
  (if (and (eq 'map type) (not value)) (setq type 'unmap))
  (let*
    ((epoch::event-handler-abort nil)	;no aborting!
     (the-list (assq type on-event::do-list))
     (info (assq screen (cdr the-list)))
     (action (cdr info)))
    (when info
	  (setcdr the-list (alist-delete screen (cdr the-list)))
	  (when (functionp action)
		(cond
		 ((or (eq type 'map) (eq type 'unmap))
		  (funcall action screen))
		 (t (funcall action screen value)))))))

;; Install on-event handlers for move, map, resize
(push-event 'map 'on-event::handler)
(push-event 'move 'on-event::handler)
(push-event 'resize 'on-event::handler)
;; Handle focus events
(push-event 'focus
	    (function
	     (lambda (type new-focus-state scr)
	       (and new-focus-state (select-screen scr)))))

(defun on-map-do (screen action)
  "On the next map event for SCREEN, call ACTION (a function of 1 argument,
the screen)"
  (let ((mlist (assq 'map on-event::do-list)))
    (push (cons (get-screen screen) action) (cdr mlist))))

(defun on-unmap-do (screen action)
  "On the next unmap event for SCREEN, call ACTION (a function of 1 argument,
the screen)"
  (let ((mlist (assq 'unmap on-event::do-list)))
    (push (cons (get-screen screen) action) (cdr mlist))))

(defun on-resize-do (screen action)
  "On the next resize event for SCREEN, call ACTION (a function of 2 arguments,
screen and event value)"
  (let ((rlist (assq 'resize on-event::do-list)))
    (push (cons (get-screen screen) action) (cdr rlist))))

(defun on-move-do (screen action)
  "On the next move event for SCREEN, call ACTION (a function of 2 arguments,
screen and event value)"
  (let ((mlist (assq 'move on-event::do-list)))
    (push (cons (get-screen screen) action) (cdr mlist))))

;;; Following code provides the 'wait-for-event' functionality:
(defvar epoch::events-pending nil
  "List of events pending while waiting for some specific event")
(defvar epoch::wait-event nil
  "Event type epoch is waiting for")
(defvar epoch::wait-function nil
  "Function to call when desired event occurs")
(defvar epoch::old-handler nil
  "Original event handler")

;;
;; epoch::dispatch-events-pending - while waiting for specific events, all
;;				other events are stashed in an elisp queue;
;;				deal with them now.
;;
(defun epoch::dispatch-events-pending ()
  (dolist (s epoch::events-pending)
	  (let*
	      (
	       (event::type (aref epoch::event 0))
	       (event::screen (aref epoch::event 2))
	       (event::value (aref epoch::event 1))
	       (callback (cadr (assq event::type event::functions)))
	       )
	    (when (and callback (functionp callback))
		  (unwind-protect
		      (funcall callback event::type event::value event::screen)
		    (when (null epoch::event-handler)
			  (setq epoch::event-handler 'event::handler)
			  (ignore-event event::type))))))
  (setq epoch::events-pending nil)
  (setq epoch::wait-event nil))

;;
;; epoch::wait-handler - special event-handler which will wait for specified
;;			 event, stashing all other events till later.
;;
(defun epoch::wait-handler ()
  (let*
      (
       (event::type (aref epoch::event 0))
       (event::screen (aref epoch::event 2))
       (event::value (aref epoch::event 1))
       )
    (if (eq event::type epoch::wait-event)
	;; it happend!  Call desired function, and do cleanup.
	(unwind-protect
	    (if (functionp epoch::wait-function)
		(funcall epoch::wait-function event::type event::value event::screen))
	  (setq epoch::wait-event nil)
	  (epoch::dispatch-events-pending))
      ;; it didn't happen yet, so stash this event for later
      (setq epoch::events-pending
	    (reverse (cons epoch::event epoch::events-pending))))))

;;
;; epoch::wait-for-event - given an epoch event-type and a function/handler
;;			   for that event (or nil), wait until specified
;;			   event happens.  Then call specified handler, and
;;			   return.
;;
(defun epoch::wait-for-event (event-type function)
  "Wait for EVENT, calling FUNCTION as handler when it occurs, then return."
  (setq epoch::old-handler epoch::event-handler) 	; save old handler
  (setq epoch::wait-event event-type)
  (setq epoch::wait-function function)
  (setq epoch::event-handler 'epoch::wait-handler)
  (while epoch::wait-event
    (epoch::dispatch-events)
    (sit-for 1))
  (setq epoch::event-handler epoch::old-handler))
