;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: XIT; Base: 10; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: MACROS
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hubertus Hohl
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/macros.lisp
;;; File Creation Date: 11/18/91 15:29:14
;;; Last Modification Time: 12/11/92 10:51:12
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 06/16/1992 (Hubertus) added support for synchronization with the X server
;;; 08/04/1992 (Matthias) Patched with-clip-mask-internal for :openwin server type.
;;; 12/10/1992 (Hubertus) removed patch for with-clip-mask-internal for :openwin 
;;;                       server type.
;;; 12/11/1992 (Matthias) mouse-documentation = nil means no change
;;;_____________________________________________________________________________


;;;_________________________________________________
;;;
;;; This file contains definitions to be 
;;; around before anything else is loaded/compiled
;;;_________________________________________________


(in-package :xit)


;________________________
;
; Defining Call Actions
;________________________

(defmacro define-call-action (name rest&key-lambda-list &body body)
  (if (null rest&key-lambda-list)
      (let ((cached-foo (gentemp (concatenate 'string
				   (string name) "-CALLBACK-FOO-")))) 
	`(let ((,cached-foo
	         (convert-to-function
		  `(lambda (*self* *part* *part-value*)
		     (declare (special *self* *part* *part-value*))
		     (let ((*contact* *self*))
		       (declare (special *contact*))
		       ,,@body)))))
	   (defmethod make-callback-function ((,(gensym) (eql ',name)) &rest ignored)
             (declare (ignore ignored))
	     ,cached-foo)))  
    `(defmethod make-callback-function ((,(gensym) (eql ',name))
					,@rest&key-lambda-list)
       (convert-to-function
	 `(lambda (*self* *part* *part-value*)
	    (declare (special *self* *part* *part-value*))
	    (let ((*contact* *self*))
	      (declare (special *contact*))
	      ,,@body))))))
	  

;_____________________________________________________________________
;
; Defining mappings from XIT event keys onto CLUE event specifications
;_____________________________________________________________________

(eval-when (compile eval load)
  (defun clue-event-spec-p (event-spec)
    (or (consp event-spec)
	(check-function event-spec))))

(defmacro define-event-key (key (&rest options
				 &key (mouse-documentation-prefix nil
				       prefix-specified-p)
				      default-mouse-documentation)
			    &body event-mappings)
  (when (clue-event-spec-p key)
    (error "Event key ~S already used as a CLUE event keyword symbol." key))
  `(progn
     ,(when (and prefix-specified-p mouse-documentation-prefix)
	`(add-event-key-for-mouse-documentation ',key))
     (defmethod mouse-documentation-prefix-for ((key (eql ',key)))
       ,(if prefix-specified-p		
	    `',mouse-documentation-prefix
	  `(or ,@(mapcar #'(lambda (event-mapping)
			     `(mouse-documentation-prefix-for ',(car event-mapping)))
			 event-mappings))))
     (defmethod remove-event-key-actions (self (key (eql ',key)))
       ,@(mapcar #'(lambda (event-mapping)
		     `(remove-event-key-actions self ',(car event-mapping)))
		 event-mappings))
     (defmethod add-event-key-actions (self (key (eql ',key))
				       &optional transformed-actions
						 position
						 ;mouse-documentation
						 )
       ,@(when default-mouse-documentation
	   `((unless (reactivity-documentation-for self ',key)
	       (setf (reactivity-documentation-for self ',key)
		   ,default-mouse-documentation))))
       ,@(mapcar
	  #'(lambda (event-mapping)
	      `(add-event-key-actions self ',(car event-mapping)
				      (or transformed-actions
					  ',(getf (cdr event-mapping)
						  :default-actions))
				      (or position
					  ',(getf (cdr event-mapping) :position))
				      ;(or mouse-documentation
					;  ',(getf (cdr event-mapping)
						;  :default-mouse-documentation))
				      ))
	  event-mappings))))


;_______________
;   
; Display Hooks 
;_______________

(defvar *open-display-hooks* nil
  "List of functions to be called with one argument display just after 
   display is opened.")

(defvar *close-display-hooks* nil
  "List of functions to be called with one argument display just before 
   display is closed.")

(defmacro add-open-display-hook (foo &rest args &key position (if-needed t)) 
  "Add FOO to the list of functions called after the toplevel display
 will be opened. When POSITION is given and equals :front the function
 will be call before all other functions already on the hook, otherwise
 before.  When POSITION is (:after bar) foo will be executed after the
 first bar currently on the list. When IF-NEEDED is non-nil adding a
 function more than once is avoided (this will not work for closure
 objects, so better use quoted lambda-lists or function bound to a
 symbol)."
  (declare (ignore position if-needed))
  `(add-hook ,foo
	     *open-display-hooks* ,.args))

(defmacro add-close-display-hook (foo &rest args &key position (if-needed t))
 "Add FOO to the list of functions called before the toplevel display
 will be closed. When POSITION is given and equals :front the function
 will be call before all other functions already on the hook, otherwise
 after. When POSITION is (:after bar) foo will be executed after the
 first bar currently on the list. When IF-NEEDED is non-nil adding a
 function more than once is avoided (this will not work for closure
 objects, so better use lambda-lists or functions bound to a symbol)."
 (declare (ignore position if-needed))
 `(add-hook ,foo *close-display-hooks* ,.args))

(defmacro remove-open-display-hook (foo)
  "Remove FOO from the list of functions called after the toplevel display
   will be opened (will not work with function objects)."
  `(remove-hook ,foo *open-display-hooks* ))

(defmacro remove-close-display-hook (foo)
  "Remove FOO from the list of functions called before the toplevel display
   will be closed (will not work with function objects)."
  `(remove-hook ,foo *close-display-hooks*))

(defun call-open-display-hooks (display)
  ;; should not be called by user program
  (dolist (foo *open-display-hooks*)
    (funcall foo display)))

(defun call-close-display-hooks (display)
  ;; should not be called by user program
  (dolist (foo *close-display-hooks*)
    (funcall foo display)))

(defvar *open-toplevel-hooks* nil
  "List of functions to be called with one argument toplevel just after 
   display is opened.")

(defmacro add-open-toplevel-hook (foo &rest args &key position (if-needed t)) 
  (declare (ignore position if-needed))
  `(add-hook ,foo
	     *open-toplevel-hooks* ,.args))

(defmacro remove-open-toplevel-hook (foo)
  "Remove FOO from the list of functions called after the toplevel window
   will be built (will not work with function objects)."
  `(remove-hook ,foo *open-toplevel-hooks* ))

(defun call-open-toplevel-hooks (toplevel)
  ;; should not be called by user program
  (dolist (foo *open-toplevel-hooks*)
    (funcall foo toplevel)))


;_________________________________________________________________
;
;  A simple facility for allocating point-vectors from a resource
;_________________________________________________________________


(defvar *point-vector-resource*
	(make-array 16 :element-type '(or point-seq null)
		    :fill-pointer 0
		    :adjustable t)
  "a stack of point-vectors.")

(defun allocate-point-vector (&optional default-size)
  ;; this should happen without-interrupts
  (let ((fp (fill-pointer *point-vector-resource*))
	vector)
    (cond ((plusp fp)
	   (prog1 (setq vector (vector-pop *point-vector-resource*))
		  (setf (fill-pointer vector) 0)
		  (setf (aref *point-vector-resource* (1- fp)) nil)))
	  (t (make-array (or default-size 16)
			 :element-type 'int16 :fill-pointer 0 :adjustable t)))))

(defun deallocate-point-vector (vector)
  (vector-push-extend vector *point-vector-resource*))

(defmacro using-point-vector ((vector-name &optional default-size) &body body)
  "Execute BODY with a point-vector bound to VECTOR-NAME. 
   The point vector is initially empty. Use (POINT-PUSH <point>) or
   (POINT-PUSH <point-x> <point-y>) to add points or point-coordinates
   to the vector."
  `(let ((,vector-name (allocate-point-vector ,default-size)))
     (macrolet ((point-push (point-or-point-x &optional point-y)
		  (let ((point (gensym)))
		    (if point-y
		      `(progn (vector-push-extend ,point-or-point-x ,',vector-name)
			      (vector-push-extend ,point-y ,',vector-name))
		      `(let ((,point ,point-or-point-x))
			 (progn (vector-push-extend (point-x ,point) ,',vector-name)
				(vector-push-extend (point-y ,point) ,',vector-name)))))))
       (unwind-protect (progn .,body)
	 (deallocate-point-vector ,vector-name)))))


;;;_______________________________________
;;;
;;; Using clip-masks for gcontexts
;;;_______________________________________

(defmacro with-clip-mask ((var contact clip-x clip-y clip-w clip-h) &body body)
  `(with-clip-mask-internal ,contact ,clip-x ,clip-y ,clip-w ,clip-h
			    #'(lambda (,var) .,body)))

(defun with-clip-mask-internal (contact clip-x clip-y clip-w clip-h continuation)
  (with-slots (width height) contact
    (if (and clip-x clip-y)
	(using-point-vector (clip-mask 4)
			      (point-push clip-x clip-y)
			      (point-push (or clip-w (- width clip-x))
					  (or clip-h (- height clip-y)))
			      (funcall continuation clip-mask))
        (funcall continuation nil))))


;;;_______________________________________
;;;
;;; Mouse Documentations
;;;_______________________________________

(defparameter *mouse-documentation-window* nil)
 
;_____________________________________________________________________________
;
;                     explicite mouse docu
;_____________________________________________________________________________

(defmethod show-mouse-documentation ((self string))
  (declare (special *mouse-documentation-window*))
  (show-documentation *mouse-documentation-window* self))

;;;_______________________________________
;;;
;;; Dummy Mouse Documentations
;;;_______________________________________

(defmethod show-documentation (self documentation)
  (declare (ignore self documentation))
  nil)

(defmethod hide-documentation (self)
  (declare (ignore self))
  nil)

(defmethod changing-documentation (self documentation continuation)
  (declare (ignore self documentation))
  (funcall continuation))


;;;____________________________________________
;;; 
;;; Mouse Documentation Support 
;;; (useful inside pointer- and button-grabs)
;;;____________________________________________
 
(defmacro with-mouse-documentation ((format-string-or-nil &rest format-args)
				    &body body)
  "Temporarily change mouse-documentation while processing body.
   If format string is nil, then do not change mouse documentation."
  (let ((var (gensym)))
    `(let ((,var ,format-string-or-nil))
       (if ,var
	   (changing-documentation
	    (locally (declare (special *mouse-documentation-window*))
	      *mouse-documentation-window*)
	    (format nil ,var ,@format-args)
	    #'(lambda () .,body))
	 (progn ,.body)))))



;;;_________________
;;;
;;;   Busy Cursor
;;;_________________

(defmacro while-busy ((&optional (cursor "watch")) &body body)
  "Temporarily display a `busy' cursor while processing body.
   Any user (input) events are simply discarded."
  `(while-busy-internal ,cursor #'(lambda () .,body)))

;;; 05/24/1991 (Hubertus) 
;;; The idea for implementing `busy' cursors was found
;;; independently by Matthias Ressel and me at the same time,
;;; although we were 500 km apart. Maybe telepathic forces were 
;;; at play here.
;;;
(defvar *busy-overlay-window* nil)

(defun while-busy-internal (cursor continuation)
  (declare (special *toplevel* *display*))
  (cond ((not (display-initialized-p))
	 (funcall continuation))
	(*busy-overlay-window*     ; nested call
	 (setf (window-priority *busy-overlay-window*) :above)
	 (display-force-output *display*)
	 (funcall continuation))
	(t 
	 (let ((*busy-overlay-window*
		(xlib:create-window
		 :parent *toplevel*
		 :class :input-only
		 ; :override-redirect :on 
		 :do-not-propagate-mask
		 #.(make-event-mask :button-motion
				    :button-5-motion :button-4-motion
				    :button-3-motion :button-2-motion
				    :button-1-motion :pointer-motion
				    :button-release :button-press
				    :key-release :key-press)
		 :x 0
		 :y 0
		 :width (contact-width *toplevel*)
		 :height (contact-height *toplevel*)
		 :cursor (convert *toplevel* cursor 'cursor))))
	    (unwind-protect
		(progn (map-window *busy-overlay-window*)
		       (display-force-output *display*)
		       (funcall continuation))
	      (destroy-window *busy-overlay-window*)
	      (display-force-output *display*))))))



;;;_________________________
;;;
;;; Busifying Event Actions
;;;_________________________

(defvar *busify-event-actions?* nil
  "If T, handle user input events specified by *busy-mode-events* inside a 
   'while-busy' context.")

(defvar *busy-action-events* '(:button-press)
  "These user input events are handled inside a `while busy' context.")

(defmethod busify-event-actions? ((contact basic-contact))
  t)

;;; Enhanced Event Handler for XIT 
;;; Note: The original CLUE event handler is overridden by this method!
;;;
(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
  ;;
  (handle-universal-events contact event)
  
  ;;
  ;; Translate event and perform contact actions
  ;;
  (handle-event-actions contact event (translate-event contact event))
  
  t)

(defmethod handle-universal-events ((contact basic-contact) (event event))
  (when (eq :exposure (slot-value (the event event) 'key))
    (with-slots (x y width height) (the event event)
      (display contact x y width height))))

(defmethod handle-event-actions ((contact basic-contact) (event event) actions)
  (dolist (action actions)
    (cluei::call-action-internal contact action)))

(defmethod handle-event-actions :around ((contact basic-contact) (event event)
					 actions)
  (with-slots (key) event
    (if (and *busify-event-actions?*
	     (busify-event-actions? contact)
	     (member key *busy-action-events*))
	(while-busy ()
		    (call-next-method))
      (call-next-method))))


;;;_________________
;;;
;;; Cursor Support
;;;_________________

(defun install-cursors (&optional (display *display*) cursor-names cursor-mask-name)
  (declare (special *display*))
  (let* ((root (display-root display))
	 (cursor-images (mapcar #'(lambda (name)
				    (defimage-from-file name))
				cursor-names))
	 (mask-image (defimage-from-file cursor-mask-name))
	 (center-x (round (image-width mask-image) 2))
	 (center-y (round (image-height mask-image) 2))
	 mask-pixmap
	 (black (convert root "black" 'color))
	 (white (convert root "white" 'color)))
    (unless (or (null mask-image)
		(some #'null cursor-images))
      (setq mask-pixmap (find-simple-mask root mask-image))
      (map 'vector
	   #'(lambda (image)
	       (create-cursor
		:source (find-simple-mask root image)
		:mask mask-pixmap
		:x center-x
		:y center-y
		:foreground black
		:background white))
	   cursor-images))))

;;;
;;; Hourglass Cursors
;;;

(defvar *hourglass-cursors* nil)

(defparameter *hourglass-cursor-names*
	      '("hourglass-0" "hourglass-1-8" "hourglass-1-4"
		"hourglass-3-8" "hourglass-1-2" "hourglass-5-8"
		"hourglass-3-4" "hourglass-7-8" "hourglass-1"))

(defun install-hourglass-cursors (&optional (display *display*))
  (declare (special *display*))
  (setf *hourglass-cursors*
      (install-cursors display *hourglass-cursor-names* "hourglass-mask")))

(defun get-percent-done-indicator (percent)
  (declare (values (or null cursor)))
  (let ((count (length *hourglass-cursors*)))
    (unless (zerop count)
      (aref *hourglass-cursors*
	    (max 0 (min (1- count) (floor (* percent (1- count)))))))))

;;; 
;;; Roundabout Cursors
;;;

(defvar *roundabout-cursors* nil)

(defparameter *roundabout-cursor-names*
	      '("roundabout-0" "roundabout-1" "roundabout-2"))

(defun install-roundabout-cursors (&optional (display *display*))
  (declare (special *display*))
  (setf *roundabout-cursors*
      (install-cursors display *roundabout-cursor-names* "roundabout-mask")))

(defun get-roundabout-indicator (tick)
  (declare (values (or null cursor)))
  (let ((count (length *roundabout-cursors*)))
    (unless (zerop count)
      (aref *roundabout-cursors* (mod tick count)))))


;;;__________________________________
;;;
;;; Percent Done Progress Indicators
;;;__________________________________
;;;
;;; Indicates progress of computation by an hourglass or roundabout cursor 
;;; with varying shape.
;;; Inside the dynamic scope of body use the function percent-done 
;;; to update the indicators.
;;;
;;; Hourglass cursors are used if TICKS is specified as T or as a number 
;;; indicating the total amount of ticks to be processed.
;;; Otherwise roundabout cursors are used.  
;;;

(defmacro with-progress-indicator ((&key ticks
					 (roundabout-step 1)
					 (process-events-p t))
				   &body body)
  `(with-progress-indicator-internal ,ticks ,process-events-p
				     ,roundabout-step
				     #'(lambda () . ,body)))

(defun with-progress-indicator-internal (ticks process-events-p roundabout-step
					 continuation)
  (let ((*current-progress-total-ticks* ticks)
	(*current-progress-tick* 0)
	(*process-events-p* process-events-p)
	(*roundabout-step* roundabout-step))
    (declare (special *current-progress-total-ticks*
		      *current-progress-tick*
		      *process-events-p*
		      *roundabout-step*))
    (while-busy ((if *current-progress-total-ticks*
		     (get-percent-done-indicator 0)
		   (get-roundabout-indicator 0)))
      (funcall continuation))))

(defun percent-done (&optional percent)
  (declare (special *current-progress-total-ticks*
		    *current-progress-tick*
		    *process-events-p*
		    *roundabout-step*
		    *toplevel* *display*))
  (when (and (boundp '*current-progress-tick*)
	     (display-initialized-p))
    (incf *current-progress-tick*)
    (cond (*current-progress-total-ticks*
	   ;; use hourglass cursors
	   (setq percent
	       (max 0
		    (min 1 (if (and (eq *current-progress-total-ticks* t)
				    percent)
			       percent
			     (/ *current-progress-tick*
				(max 1 *current-progress-total-ticks*))))))
	   (setf (window-cursor *busy-overlay-window*)
	       (get-percent-done-indicator percent)))
	  (t
	   ;; use roundabout cursors
	   (when (zerop (mod *current-progress-tick* *roundabout-step*))
	     (setf (window-cursor *busy-overlay-window*)
		 (get-roundabout-indicator
		  (floor *current-progress-tick* *roundabout-step*))))))
    (if *process-events-p*
	(process-all-events *display*)
      (display-force-output *display*))))

;;; Open Display Hooks

(add-open-display-hook 'install-hourglass-cursors)
(add-open-display-hook 'install-roundabout-cursors)

;;;_____________________________________
;;;
;;; Loop over all windows (even non-XIT)
;;;_____________________________________

(defmacro do-all-windows ((var &optional root result) &body body)
  `(block nil
     (do-windows-internal #'(lambda (,var) ,.body)
			,(when result `(function (lambda () ,result)))
			t
			,(if root root '(drawable-root (screen-root (car (display-roots *display*)))
			 )))))

(defmacro do-windows ((var type &optional root result) &body body)
  `(block nil
     (do-windows-internal #'(lambda (,var) ,.body)
			,(when result `(function (lambda () ,result)))
			,type
			,(if root root '(drawable-root (screen-root (car (display-roots *display*)))
			 )))))

(defun do-windows-internal (body-foo  result-foo type root)
  (when (typep root type) (funcall body-foo root))
  (dolist (p (query-tree root))		; query-tree does also work for root etc.
    (do-windows-internal body-foo nil type p ))
  (when result-foo (funcall result-foo)))



;;;______________________________
;;;
;;; Client Event Synchronization
;;;______________________________

(defvar *awaiting-synchronize-event-p* nil)

(defun await-synchronize-event (contact)
  "Loop processing events until a sychronize-event is produced
   by calling SEND-SYNCHRONIZE-EVENT.
   The value returned is the value given to SEND-SYNCHRONIZE-EVENT."
  (let ((*awaiting-synchronize-event-p* t))
    (catch :send-synchronize-event
      (loop (process-next-event (contact-display contact))))))

(defun send-synchronize-event (&optional value)
  (when *awaiting-synchronize-event-p*
    (throw :send-synchronize-event value)))

(defmacro with-synchronous-mode ((contact &optional (cursor "question_arrow"))
				 &body body)
  "While executing BODY, user input events received by any of the currently mapped 
   children of the toplevel are discarded and the cursor displayed on the toplevel     is changed to the one specified by CURSOR. 
   After executing BODY, the application loops processing events until a
   sychronize-event is produced by calling SEND-SYNCHRONIZE-EVENT.
   The value given to this function is the value returned by WITH-SYNCHRONOUS-MODE."
  `(while-busy (,cursor)
     ,@body
     (await-synchronize-event ,contact)))



;;;_________________________________
;;;
;;; Synchronizing with the X Server
;;;_________________________________

;;; the definition of the :token-event event-key can be 
;;; found in interaction-window.lisp.

(define-event-key :token-event ()
  ((:client-message :__token check-token 0)))

;;; User Interface Functions
;;; 
(defun await-token-event (contact &optional (token-data 0))
  "Send a token event to the server and loop processing events
   in the input buffer until the token is received again."
  (send-token-event contact token-data)
  (await-synchronize-event contact))    
    
(defmacro waiting-for-token-event ((contact &optional (token-data 0)) &body body)
  `(multiple-value-prog1 ,@body
     (await-token-event ,contact ,token-data)))

(defmethod send-token-event ((self contact) &optional (token-data 0))
  (let ((token-event-handler (token-event-handler self)))
    (send-event token-event-handler
		:client-message nil
		:window token-event-handler
		:event-window token-event-handler
		:type :__token
		:format 32
		:data (list token-data))
    (display-force-output (contact-display token-event-handler))))


(defmethod token-event-handler ((self basic-contact))
  "The contact used to send and receive token events."
  (toplevel-window self))

(defclass token-event-handler-mixin ()
  ((token-event-action :initarg :token-event-action
		       :initform '(call :synchronize-event 0)
		       :accessor token-event-action))
  (:documentation "Mix this class into contact classes which are used
                   to send and receive token events."))

(defmethod initialize-instance :after ((self token-event-handler-mixin)
				       &rest initargs)
  (change-reactivity self :token-event (token-event-action self)))


;;; internals
;;;
(defun create-token-atom (display)
  (intern-atom display :__token))

(add-open-display-hook 'create-token-atom)

(defun check-token (data)
  (elt data 0))




      
