;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: mouse-tracking
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/mouse-tracking.lisp
;;; File Creation Date: 11/11/91 09:22:34
;;; Last Modification Time: 06/16/92 16:59:23
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 06/16/92 (Matthias): added waiting-for-token-event to process all 
;;;                      events caused by grab-pointer before entering
;;;                      event-case
;;;
;;;_____________________________________________________________________________

;;x1, y1 funktioniert noch nicht, vergleiche xpaint-new.lisp

(in-package :xit)

;;; Mouse tracking

(defparameter *dragging-mouse-state-parameters*
    '((:before (x1 y1) ())
      (:dragged (x1 y1) ((event-window event-window)
		  (x x) (y y) (state state) (time time) (hint-p hint-p)))
      (:after () ((event-window event-window+)
		  (x x+) (y y+) (state state+) (code code+)
		  (time time+) (child child+)))
      (:abort () ((event-window event-window+)
		  (x x+) (y y+) (state state+) (code code+)
		  (time time+) (child child+)))
      (:after-always () ((event-window event-window+)
		  (x x+) (y y+) (state state+) (code code+)))
      (:dragged-always () ((event-window event-window)
			   (x x) (y y))))
  "Alist relating dragging-mouse clause keywords to their available parameters.
If changed recompute the variable *dragging-mouse-keywords*, too.")

(defparameter *dragging-mouse-keywords*
    (delete :dragged-always
	    (delete :after-always (mapcar #'car *dragging-mouse-state-parameters*)))
  "List of the allowable keywords in dragging-mouse clauses.
Should be consistent with the variable *dragging-mouse-state-parameters*")

(defun make-lambda-form-arglist (key user-args)

  "Computes from a dragging-mouse clause key and the user given
argument list (including renaming of given parameter names) the
necessary parameter list for the function built from the clause, the
arguments the function is called with, the list of required event
slots, and a list of additional virtual slots (e.g. x1, y1).
USER-ARGS is a list of either a predefined parameter name (as given by
the corresponding entry in *dragging-mouse-state-parameters*) or a
two element list where the second element is an new name for the
predefined parameter name given as the first element.  Returns four
values: lambda-parameter list, argument list, list of required event
slots and a list of additional slots."

  (let* ((event-slot-parameters
	  (caddr (assoc key *dragging-mouse-state-parameters*)))
	 (additional-parameters
	  (cadr (assoc key *dragging-mouse-state-parameters*)))
	 (lambda-args nil)
	 (lambda-parameters nil)
	 (event-slots-list nil) (additional-slots nil)
	 (wrong-parameters nil))
    (dolist (user-arg user-args)
      (let* ((car-user-arg (if (listp user-arg) (car user-arg) user-arg))
	     (cadr-user-arg (if  (listp user-arg) (cadr user-arg) user-arg))
	     (state-parameter
		    (car (or (member car-user-arg additional-parameters)
			     (member car-user-arg event-slot-parameters
				     :key #'car)))))
	(cond ((consp state-parameter)
	       (push (car state-parameter) lambda-args)
	       (push state-parameter event-slots-list)
	       (push cadr-user-arg lambda-parameters))
	      (state-parameter
	       (push state-parameter lambda-args)
	       (push cadr-user-arg lambda-parameters)
	       (push state-parameter additional-slots))
	      (t (push user-arg wrong-parameters)))))
    #||(when (eq key :abort) ;include Slots code and state
      (pushnew (assoc 'code event-slot-parameters) event-slots-list)
      (pushnew (assoc 'state event-slot-parameters) event-slots-list)
      (pushnew (assoc 'event-window event-slot-parameters) event-slots-list)
      (pushnew (assoc 'x event-slot-parameters) event-slots-list)
      (pushnew (assoc 'y event-slot-parameters) event-slots-list)
      )
    (when (eq key :dragged)
      (pushnew (assoc 'event-window event-slot-parameters) event-slots-list)
      (pushnew (assoc 'x event-slot-parameters) event-slots-list)
      (pushnew (assoc 'y event-slot-parameters) event-slots-list))||#
     (when wrong-parameters
      (warn "Arglist of ~s contains wrong parameters~{ ~s~^,~}."
	    key (nreverse wrong-parameters)))
    (values ;; nreverse just for easier debugging
     ;; lambda-parameters and lambda-args should be reversed both or none
     (nreverse event-slots-list) (nreverse additional-slots)
     (nreverse lambda-parameters) (nreverse lambda-args))))

(defmacro dragging-mouse ((grab-window  &key abort-events 
						 (window grab-window)
						 (x1 nil) (y1 nil)
						 (cursor "gumby")
						(drag t) optimize
						confine-to
						 (mouse-documentation "")) 
			      &rest clauses)

  "Macro for typical mouse dragging application. Includes dragging the
   pointer, starting an event loop, tracking the pointer, normal ending
   by some pointer event or aborting by a pointer or keyboard event and
   undragging the pointer. GRAB-WINDOW names the variable bound to the
   dragging-window througout the dragging. A grab-window may be
   explicitely given by WINDOW.  The given CURSOR will replace the
   current cursor during the grab. MOUSE-DOCUMENTATION replaces the
   current mouse documentation (if available). If DRAG is nil, the
   dragging is ended by pressing any mouse button, otherwise it reacts on
   releasing a button. CONFINE-TO optionally confines the pointer to
   the given window, not necessarly related to the dragging-window. If
   OPTIMIZE is t, motion-event will be thinned out for quick response.
   ABORT-EVENTS is a list of event-specifications that describe when the
   grab should be aborted and the abort action will be executed. An
   event-specification is a list of the event type (:button-press,
   :button-release, :key-press, or :key-release), a buttoncode (number or
   eg.  :button-2) or keycode (number between 8 and 255) and optional
   modifiers (e.g. :shift).  The code may be given as *, in that case any
   button or code will match.  When * is given as one of the modifiers,
   any event inlcuding these modifiers will match, otherwise an exact
   match of the modifiers is required. Each clause starts with a keyword
   (one of *dragging-mouse-keywords*) and a list of variables bound
   to the corresponding event slots (like event clauses in event-case)
   and a body of expressions that may refer to these and any free variables. "

  (let ((unknown-clauses
	 (remove-if  #'(lambda (clause) (and (listp clause)
					 (member (car clause)
						 *dragging-mouse-keywords*)))
			 clauses))
	(unknown-keywords nil))
    (dolist (clause (copy-list unknown-clauses))
      (when (listp clause)
	(push (car clause) unknown-keywords)
	(setf unknown-clauses (delete clause unknown-clauses))))
    (when (or unknown-clauses unknown-keywords)
      (error "In macro dragging-mouse~&~
              ~@[Keywords~{ ~s~^;~} should be one of~{ ~s,~^~}.~:*~]~*~&~
              ~@[Clauses should be lists:~{ ~s~}.~]"
	     unknown-keywords *dragging-mouse-keywords* unknown-clauses)))
  (flet ((make-lambda-form-et-al (clause)
	   (let ((key (car clause)))
	     (cond ((null (cdr clause))
		    nil)
		   ((listp clause)
		    (multiple-value-bind (event-slots additional-slots params args)
			(make-lambda-form-arglist
					       key  (cadr clause))
		    `(,key
			  (,event-slots ,additional-slots
			    (function (lambda ,(cons grab-window
						 params)
				 ,.(cddr clause)))
			    ,(cons window args)))))))))
    (apply #'drag-mouse window  :cursor cursor
		       :drag drag
		       :optimize optimize
		       :confine-to confine-to
		       :mouse-documentation mouse-documentation
		       :abort-events abort-events
		       :x1 x1 :y1 y1
		       (mapcan #'make-lambda-form-et-al
				 (cons '(:after-always (code state event-window x y))
				       (cons '(:dragged-always (event-window x y))
                                       clauses))))))

(defun event-member (event-desc event-list)
  (member event-desc event-list :test #'event-equal))

(defun event-equal (e1 e2)
  (or (eql e1 e2)
      (and (listp e1) (listp e2)
	   (case (car e1)
	     ((:button-release :button-press :key-release :key-press)
	      (and (eql (car e1) (car e2))
		   (or (eql (second e1) (second e2))
		       (eql (second e2) '*))
		   (or (eql (third e1) (third e2))
		       (and (eql (fourth e2) :any-modifier)
			    (zerop (logandc1 (third e1) (third e2)))))))))))

(defun normalize-events-code (code)
  (cond ((not (consp code)) code)
	((constantp code) ; then quoted object
	 (unless (and (eq (car code) 'quote)
		      (listp (cadr code)))
	   (error "Constant event-list is malformed:~&~s"
		  code))
	 `(quote ,(mapcar #'normalize-event (cadr code))))
	((eq (car code) 'list)
	 `(list ,.(mapcar #'normalize-single-event-code (code))))
	(t code)))

(defun normalize-single-event-code (code)
  (cond ((not (listp code)) code)
	((constantp code) ; then quoted object
	 (unless (and (eq (car code) 'quote)
		      (listp (cadr code)))
	   (error "Constant event is malformed:~&~s"
		  code))
	 (normalize-event (cadr code)))
	(t code)))

(defun normalize-events (events)
  (mapcar #'normalize-event events))

(defun normalize-event (event-descr)
  (let ((event-type (car event-descr)))
    (case event-type
      ((:button-release :button-press :key-release :key-press)
       (let ((code (cadr event-descr))
	     (modifiers (cddr event-descr)))
	 (case event-type
	   ((:button-release :button-press)
	    (setq code
		(case code
		  (:button-1 1)
		  (:button-2 2)
		  (:button-3 3)
		  (:button-4 4)
		  (:button-5 5)
		  (t code)))
	    (unless (typep code '(or (member *) (integer 1 5)))
	      (error "~s is no proper mouse button." code)))
	   ((:key-press :key-release)
	    (unless (typep code '(or (member *) (integer 8 255)))
	      (error "~s is no proper key code." code))))
	 `(,event-type ,code
	       ,(if (typep (car modifiers) 'mask16) (car modifiers)
		 (apply #'make-state-mask (remove '* modifiers)))
	       ,@(when (member `* modifiers)
		 (list :any-modifier)))))
      (t (warn "Unknown (or not yet implemented) event-type ~S" event-type)
	 event-descr))))
	    
(defun drag-mouse (grab-window &rest args 
			   &key x1 y1 (cursor "cross") (drag t)
				optimize confine-to
				mouse-documentation abort-events
				before dragged after abort after-always
				dragged-always
			   &allow-other-keys)
  (declare (ignore args))
  (let* ((button-key-event-slot-descrs (union
					(union (car abort) (car after) :key #'car)
					    (car after-always) :key #'car))
	 (button-key-event-slots `(,.(mapcar #'car button-key-event-slot-descrs)))
	 (motion-event-slots (union (car dragged-always) (car dragged) :key #'car))
	 (additional-slots (reduce #'union (list (cadr before) (cadr dragged)
						 (cadr after) (cadr abort))))
	 (drag-var (gensym))
	 (x1-var (when x1 (gensym)))
	 (y1-var (when y1 (gensym)))
	 (grab-var (gensym))  (display-var (gensym))
	 (aborted-var (gensym)))
    
    `(let ((normalized-abort-events (normalize-events ,abort-events))
	   (,aborted-var nil)
	   (,grab-var ,grab-window)
	   (,drag-var ,drag)
	   ,@(when x1 (list `(,x1-var ,x1)))
	   ,@(when y1 (list `(,y1-var ,y1)))
      	   ,@(mapcar #'(lambda (var) `(,var :unbound)) button-key-event-slots)
	   ,@(mapcar #'(lambda (var) `(,var :unbound)) additional-slots))
       ,@(when x1 (list `(setq x1 ,x1-var)))
       ,@(when y1 (list `(setq y1 ,y1-var)))
       (with-slots ((,display-var display)) ,grab-var
	 (unwind-protect
	     (ignoring-errors
	      (let ((grab-pointer-status
		     (waiting-for-token-event (,grab-var)
			(grab-pointer ,grab-var
				       (list (if ,drag-var :button-release
					       :button-press) :pointer-motion) 
				       :owner-p T
				       :sync-pointer-p t
				       :confine-to ,confine-to
				       :cursor (convert ,grab-var ,cursor 'cursor)
				       :time nil))))
	      (case grab-pointer-status
		(:success
		 ,@(when before
		     `((funcall ,(caddr before) ,.(cadddr before))))
		 (with-mouse-documentation (,mouse-documentation)
		   (allow-events ,display-var :async-pointer)
		   (event-case (,display-var :discard-p T 
					     :force-output-p t)
			       (motion-notify ,motion-event-slots
					      (multiple-value-setq (x y)
						(contact-translate event-window x y ,grab-var))
					      (unless (and ,optimize (discard-but-last-motion-event
								      ,grab-var
								      (list (if ,drag-var :button-release :button-press)
									    :key-press :key-release)))
			       
						,@(when dragged
						    `((funcall ,(caddr dragged) ,.(cadddr dragged))))
						;; make the new position the current position
						,@(when (member 'x1 additional-slots)
						    (list `(setq x1 x)))
						,@(when (member 'y1 additional-slots)
						    (list `(setq y1 y))))
					      nil)
			       (button-press ,button-key-event-slot-descrs
					     (setq ,.(apply #'append button-key-event-slot-descrs))
					     (multiple-value-setq (x y)
					    (contact-translate event-window+ x y ,grab-var))
					  (cond ((event-member (list :button-press code state)
								  normalized-abort-events)
						    (setq ,aborted-var t)
						    t)
						   (t	 (unless ,drag-var t))))
			       (button-release ,button-key-event-slot-descrs
					       (setq ,.(apply #'append button-key-event-slot-descrs))
					       (multiple-value-setq (x y)
					    (contact-translate event-window+ x y ,grab-var))
					  (cond ((event-member (list :button-release code state)
								    normalized-abort-events)
						      (setq ,aborted-var t)
						      t)
						     (t	 (when ,drag-var t))))
			       (key-press ,button-key-event-slot-descrs
					  (setq ,.(apply #'append button-key-event-slot-descrs))
					  (multiple-value-setq (x y)
					    (contact-translate event-window+ x y ,grab-var))
					  (cond ((event-member (list :key-press code state)
							       normalized-abort-events)
						 (setq ,aborted-var t)
						 t)
						))
			       (key-release ,button-key-event-slot-descrs
					    (setq ,.(apply #'append button-key-event-slot-descrs))
					    (multiple-value-setq (x y)
					      (contact-translate event-window+ x y ,grab-var))
					    (cond ((event-member (list :key-release code state)
								 normalized-abort-events)
						   (setq ,aborted-var t)
						   t)
						  )))
		   (cond (,aborted-var
			  ,@(when abort
			      `((funcall ,(caddr abort) ,.(cadddr abort)))))
			 (t
			  ,@(when after
			      `((funcall ,(caddr after) ,.(cadddr after))))))))
		    (otherwise
		     (grab-pointer-failed grab-pointer-status)))))
	   (ungrab-pointer ,display-var)
	   (display-force-output ,display-var))))))
  
(defun grab-pointer-failed (status)
  (warn "grab-pointer failed, ~a"
	(case status
	  (:already-grabbed "pointer is already actively by some other client.")
	  (:frozen "pointer is frozen by an active grab of another client.")
	  (:not-viewable "one of the grab window and the :confine-to window is not viewable.")
	  (:invalid-time "specified time is inconsistent.")))
  (force-output))
