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

(in-package "CLUEI")

#|| [Hubertus 11/10/90]

- patched DISPATCH-EVENT to handle non-contact event drawables of type DRAWABLE.

- added a MANAGE-GEOMETRY method for BASIC-CONTACT
  (there is a MANAGE-GEOMETRY :AROUND method for BASIC-CONTACT, but the primary was defined for CONTACT only!)

||#

(defun dispatch-event (event event-key send-event-p sequence 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) (eq class 'drawable))
	;; *********************                            ^^^^^^^^^^ needed too!!
	;; in clue.old this was (not (typep contact) 'basic-contact)
	
	(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 manage-geometry ((parent composite) (contact basic-contact) x y width height border-width &key)  
  (declare (type (or null int16) x y)
	   (type (or null card16) width height border-width)
	   (values success-p x y width height border-width))
  (with-slots ((contact-x x)
	       (contact-y y)
	       (contact-width width)
	       (contact-height height)
	       (contact-border-width border-width)) (the basic-contact contact)

    ;; Just ensure positive size
    (let* ((requested-width   (or width contact-width))
	   (acceptable-width  (if (zerop requested-width)
				  *default-contact-width*
				  requested-width))
	   (requested-height  (or height contact-height))
	   (acceptable-height (if (zerop requested-height)
				  *default-contact-height*
				  requested-height)))
      
      (values (and (= requested-width acceptable-width)
		   (= requested-height acceptable-height))
	      (or x contact-x)
	      (or y contact-y)
	      acceptable-width
	      acceptable-height	    
	      (or border-width contact-border-width)))))

