;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: VIRTUALS
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/virtual-window.lisp
;;; File Creation Date: 6/06/90 16:41:33
;;; Last Modification Time: 03/19/92 08:27:09
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________________ 


(in-package :xit)

;;;_________________________________________________________________
;;;
;;;                 A Framework for Virtual Windows
;;;_________________________________________________________________
;;;
;;; Virtual Windows are contacts without an associated X-Window.
;;; 
;;; Note: This implementation is *not* based on CLUE's virtual
;;; facility (an extremely buggy, quick and dirty hack!). 
;;; It is solely build upon XIT's BASIC-WINDOW contact-class.

(defcontact virtual-window (basic-window)
  ((name :initform :virtual-window)
   (updating? :type boolean
	      :initform nil))
  (:resources
   (inside-border :initform 0)			; don't change this!
   (border-width :initform 0)			; don't change this!
   )
  (:documentation "a contact without an X-Window"))

(defmethod print-object ((instance virtual-window) stream)
  (let ((name (if (slot-boundp instance 'name)
		  (contact-name instance)
		  :uninitialized)))
    #+lispm
    (si:printing-random-object (instance stream)
      (princ (cluei::class-name-of instance) stream)
      (write-char #\space stream)
      (princ name stream))
    #-lispm
    (progn
      (write-string "#<" stream)
      (princ (cluei::class-name-of instance) stream)
      (write-char #\space stream)
      (princ name stream)
      (write-char #\> stream))))


(defmethod (setf contact-state) (state (self virtual-window))
  (check-type state (member :withdrawn :managed :mapped))
  (let ((old-state (slot-value (the contact self) 'state)))
    (unless (eq old-state state)
      (setf (slot-value (the contact self) 'state) state)
      (if (realized-p self)
	  ;; When realized, change state immediately
	  (progn
	    (when (or (eq old-state :withdrawn)
		      (eq state     :withdrawn))
	      ;; Let parent react to transition to/from g.mgmt.
	      (change-layout (contact-parent self) self))
	    
	    (if (eq state :mapped)
		;; Was unmapped, now mapped
		(update self)
		(when (eq old-state :mapped)
		  ;; Was mapped, now unmapped
		  (clear self))))	  
	  ;; Not realized, let UPDATE-STATE do the work
	  (setf (cluei::display-update-flag (contact-display self)) t)))
    state))

(defmethod realize ((self virtual-window))
  ;; Ensure the parent is realized
  (with-slots (parent) self
    (unless (realized-p parent)
      (realize parent)))
  ;; Use the PARENT's window
  (setf (window-id self) (window-id (contact-parent self))))

(defmethod realize :after ((self virtual-window))
  ;; compute virtual's event-mask from event-translations
  (with-slots (event-mask) self
    (setf event-mask (cluei::contact-event-translations-mask self)))
  ;; update parent's event-mask
  (update-event-mask (contact-parent self))
  ;; and display SELF
  (update self))

(defmethod cluei::initial-state-transition ((self virtual-window))
  "Return the old-state/new-state for the initial (setf contact-state) after
   the virtual is realized.
   Return nil if (setf contact-state) need not be called, i.e. no
   initial state transition is necessary."
  (with-slots (cluei::state) self
    (when (eq :mapped cluei::state)
      (values nil :mapped))))

(defmethod accept-focus-p ((self virtual-window))
  "Returns non-nil when CONTACT is willing to become the keyboard input focus"
  nil)

(defmethod move ((self virtual-window) x y)
  (with-slots ((contact-x x) (contact-y y)) self
    (let ((position-changed-p (or (not (= contact-x x)) (not (= contact-y y)))))
      (when position-changed-p
	(setf contact-x x)
	(setf contact-y y))
      position-changed-p)))
  
(defmethod resize ((self virtual-window) width height border-width)
  (with-slots ((contact-width width)
	       (contact-height height)
	       (contact-border-width border-width)) self
    (let ((size-changed-p (or (not (= contact-width width))
			      (not (= contact-height height))
			      (not (= contact-border-width border-width)))))
      (when size-changed-p
	(setf contact-width width)
	(setf contact-height height)
	(setf contact-border-width border-width))
      size-changed-p)))

;;;
;;; UPDATE-STATE Hooks
;;;

;;; this informs update-state to realize the virtual
;;;
(defmethod initialize-instance :after ((self virtual-window) &rest initargs)
  (setf (cluei::display-update-flag (contact-display self)) t))

;;; because update-tree has been patched to call update-tree
;;; on realized children, we have to define this method for virtuals
;;;
(defmethod cluei::update-tree ((self virtual-window))
  ;; do nothing
  )

(defmethod initialize-geometry ((self virtual-window))
  ;; Do nuthin'
  )

;;;
;;; Triggers for Event Handling
;;;

(defmethod add-event :after ((self virtual-window) event-spec &rest actions)
  (update-event-mask (contact-parent self) self))


(defmethod delete-event :after ((self virtual-window) event-spec)
  (update-event-mask (contact-parent self)))


;;;
;;; Update and Display Operations on Virtual-Windows
;;;

(defmethod update ((self virtual-window))
  (when (and (realized-p self)
	     (mapped-p self))			; this must *also* be checked!
    (display self)))


;;; the UPDATING-VIRTUAL macro wraps update operations 
;;; (clear and display) around the body being executed.
;;; Additionally it takes care to prevent obsolete
;;; update operations in nested calls.
;;;
(defmacro updating-virtual (virtual &body body)
  `(updating-virtual-internal ,virtual #'(lambda () . ,body)))

(defun updating-virtual-internal (virtual continuation)
  (with-slots (parent updating?) virtual
    (with-slots (update-virtuals?) parent
      (if (or updating? (not update-virtuals?))
	  ;; there is already an updating-virtual pending
	  ;; (or disabled by parent) so just execute the body.
	  (funcall continuation)
	  ;; otherwise wrap clear and display operations around
	  ;; the execution of body.
	  (unwind-protect
	      (progn
		(setf updating? T)
		(clear virtual)
		(multiple-value-prog1
		  (funcall continuation)
		  (update virtual)))
	    (setf updating? nil))))))


(defmethod destroy ((self virtual-window))
  (with-slots (parent) self
    (updating-virtual self
      ;; Destroy the contact and all its resources
      (when (and (realized-p self) 	     ;; only destroy realized windows once
		 (contact-parent self))      ;; Don't destroy screen
	(setf (contact-state self) :withdrawn)
	(setf (window-id self) -1))			
      ;; Delete contact from its parent's child list
      (delete-child parent self)
      ;; update parent's event-mask
      (update-event-mask parent))))

(defmethod clear ((self virtual-window) &key (x 0) (y 0) width height exposures-p)
  (declare (ignore x y width height exposures-p))
  (when (realized-p self)
    (multiple-value-bind (reg-x reg-y reg-w reg-h) (enclosing-region self T T)
      (clear-area self :x reg-x :y reg-y
		  :width reg-w :height reg-h :exposures-p exposures-p))))

;;; Notify parent after clearing a virtual-window.
;;; This allows the parent to implement a specific redisplay strategy
;;; for virtuals that are involved in the clear operation.
;;;
(defmethod clear :after ((self virtual-window) &key (x 0) (y 0) width height exposures-p)
  (declare (ignore x y width height exposures-p))
  (update-for-virtuals-needed (contact-parent self) self (enclosing-region self T)))

(defmethod background ((self virtual-window))
  (background (contact-parent self)))

(defmethod inside-contact-p :around ((self virtual-window) x y)
    ;; perform a fast test first
    (and (maybe-inside-contact-p self x y)
	 ;; then perform more specific tests
	 (call-next-method)))

(defmethod maybe-inside-contact-p ((self virtual-window) x y)
  "A fast test, that returns T, if X/Y (in contact coordinates) is potentially
   inside the display-area of SELF."
  (multiple-value-bind (reg-x reg-y reg-w reg-h) (enclosing-region self nil T)
    (and (<= reg-x x)
	 (< x (+ reg-x reg-w))
	 (<= reg-y y)
	 (< y (+ reg-y reg-h)))))

;;; the following methods (and the enclosing-region method defined 
;;; for basic-contact) are intended to be specialized by subclasses
;;;
(defmethod inside-contact-p ((self virtual-window) x y)
  "Returns T if X/Y (in contact coordinates) is in the display-area of SELF,
   assuming that X/Y passed the maybe-inside-contact-p test."
  T)						


;;;______________________________________
;;;
;;;   Basic Virtual-Window Operations
;;;______________________________________


(defmethod flash-window ((self virtual-window) &optional (sleep-seconds 0.3))
  (with-slots (x y width height display) self
    (using-gcontext (gc :drawable self
			:function BOOLE-XOR
			:foreground *inversion-pixel*) 
      (draw-rectangle-inside self gc x y width height t)
      (display-force-output display)
      (sleep sleep-seconds)
      (draw-rectangle-inside self gc x y width height t)
      (display-force-output display))))


;;; Specialized versions for moving virtual windows with the mouse
;;;
(defmethod copy-contents ((self virtual-window) gc destination dx dy)
  (let ((br (bounding-region self)))
    (copy-area self gc (region-x br) (region-y br)
	       (region-w br) (region-h br)
	     destination dx dy)))

(defmethod pixmap-of-window ((window virtual-window))
  (with-slots (width height border-width) window
    (let* ((br (bounding-region window))
	  (pixmap (create-pixmap :width (region-w br)
			       :height (region-h br)
			       :drawable window
			       :depth (contact-depth window))))
    (using-gcontext (pgc :drawable pixmap
			 :foreground *black-pixel*
			 :background *white-pixel*
			 :fill-style :opaque-stippled 
			 :stipple *shading-mask*)
      (draw-rectangle-inside pixmap pgc 0 0 (region-w br) (region-h br) T))
    (using-gcontext (sgc :drawable window
			 :foreground *black-pixel*
			 :background *white-pixel*
			 :subwindow-mode :include-inferiors)
      (copy-contents window sgc pixmap border-width border-width))
    pixmap)))

(defmethod move-window-with-mouse-by-wire ((self virtual-window)
					   &key drag in-bounds-p)
  (move-window-with-mouse-fast self))

(defmethod move-window-with-mouse-nice ((self virtual-window)
					&key drag in-bounds-p)
  (move-window-with-mouse-fast self))

(defmethod move-window-with-mouse-fast ((self virtual-window))
  (declare (special *white-pixel* *black-pixel* *shading-mask*))
  (with-slots (display parent x y width height border-width) self
    (multiple-value-bind (mouse-x mouse-y)
       (query-pointer self)
      (using-gcontext (gc :drawable parent
			  :subwindow-mode :include-inferiors
			  :foreground *black-pixel*
			  :background *white-pixel*)
	(let* ((pwidth (contact-total-width self))
	       (pheight (contact-total-height self))
	       (x-pos x)
	       (y-pos y)
	       (save-under? (eq (window-save-under self) :on))
	       (pixmap (create-pixmap :width pwidth :height pheight :drawable self
				      :depth (contact-depth parent)))
	       (save-pixmap (create-pixmap :width pwidth :height pheight :drawable parent
					   :depth (contact-depth parent))))

	  ;; 11/26/1990 (Matthias )
	;; Warp mouse pointer to nearest contact border if out of bounds
	;; (that's the case if move is chosen within a menu)
	(setq mouse-x (min (max mouse-x 0) width)
	      mouse-y (min (max mouse-y 0) height))
	;; **** difference to basic-window's MOVE-WINDOW-WITH-MOUSE ****
	(warp-pointer parent
		      (+ x-pos  mouse-x)
		      (+ y-pos  mouse-y))
	(process-all-events display)

	;; Copy window's contents (and simulated borders) into pixmap.
	  ;; This may leave holes for windows without :backing-store
	  ;; which are only partially visible. These holes and the borders
	  ;; are filled with a shading gray stipple.
	  ;; Using totop-window may prevent leaving holes, but this also
	  ;; changes the stacking order.

	  (using-gcontext (pgc :drawable pixmap
			       :foreground *black-pixel*
			       :background *white-pixel*
			       :fill-style :opaque-stippled 
			       :stipple *shading-mask*)
	    (draw-rectangle-inside pixmap pgc 0 0 pwidth pheight T))
	  (using-gcontext (sgc :drawable self
			       :foreground *black-pixel*
			       :background *white-pixel*
			       :subwindow-mode :include-inferiors)
	    ;; **** difference to basic-window's MOVE-WINDOW-WITH-MOUSE ****
	    (copy-area self sgc x y width height
		       pixmap border-width border-width))

	  ;; don't bury-window because this may generate exposure events that are discarded
	  ;; by the event-loop below (using :discard-p = nil is expensive in that it generates
	  ;; a lot of useless events that must be processed afterwards!)

	  (when save-under?
	    ;; If a contact is moved that saves the pixels underneath
	    ;; (:save-under = T) :subwindow-mode :include-inferiors may leave
	    ;; garbage on screen afterwards under special circumstances.
	    ;; To prevent this we unmap the contact first.
	    (setf (contact-state self) :managed))
	
	  (copy-area parent gc x-pos y-pos pwidth pheight save-pixmap 0 0)
	  (copy-area pixmap gc 0 0 pwidth pheight parent x-pos y-pos)
	  ;; (warp-pointer parent x-pos y-pos)
	  (grab-pointer parent
			'(:button-press :pointer-motion) 
			:owner-p T
			:confine-to parent
			:cursor (convert self "fleur" 'cursor)
			:time nil)
	  (unwind-protect
	      (event-case (display :discard-p T 
				   :force-output-p t)
		(motion-notify (x y event-window)
		   (unless (discard-but-last-motion-event self '(:button-press))
		     (copy-area save-pixmap gc 0 0 pwidth pheight parent x-pos y-pos)
		     ;; ***** added coordinate transformation
		     (multiple-value-bind (parent-x parent-y)
			 (contact-translate event-window x y parent)
		       (setq x-pos (- parent-x mouse-x))
		       (setq y-pos (- parent-y mouse-y)))
		     (copy-area parent gc x-pos y-pos pwidth pheight save-pixmap 0 0)
		     (copy-area pixmap gc 0 0 pwidth pheight parent x-pos y-pos)
		     )
		     nil)
		(button-press ()
		  (copy-area save-pixmap gc 0 0 pwidth pheight parent x-pos y-pos)
		  t))
	    (ungrab-pointer display)
	    (move-window self x-pos y-pos)
	    (when save-under?			; map :save-under window again
	      (setf (contact-state self) :mapped))
	    (free-pixmap pixmap)
	    (free-pixmap save-pixmap))
	  (values x-pos y-pos)))))) 


;;;___________________________________________
;;;
;;;  A Composite for managing Virtual-Windows
;;;___________________________________________

(defcontact composite-for-virtuals (composite)
  ((name :initform :composite-for-virtuals)
   (virtual-count :initform 0
		  :reader virtual-count
		  :documentation
		  "number of virtual-windows, used for optimization.
                   (may be also used to decide on special update strategies, ...)")
   (exposure-by-region? :type boolean
			:initform NIL
			:allocation :class)
   ;; internal slots
   (mouse-contact :type (or null virtual-window)
		  :accessor mouse-contact
		  :initform nil
		  :documentation "Set to the virtual window the mouse is in")
   (update-virtuals? :type boolean :initform T)
   (disable-exposures? :type boolean :initform NIL)
   )
  (:documentation
    "A composite that may have virtual-windows."))

;;; Note: a non-NIL EXPOSURE-BY-REGION? slot value limits the update
;;; of virtuals to those that intersect with the exposure event region. 
;;; However, before updating virtuals the default actions
;;; triggered by an exposure event for the composite are performed.
;;; So in order to work with a non-NIL EXPOSURE-BY-REGION? value, you
;;; must ensure that these actions don't clear the composite's area!

(defmethod add-child :after ((self composite-for-virtuals) (child virtual-window)
			     &key)
  (with-slots (virtual-count) self
    (incf virtual-count)))

(defmethod delete-child :after ((self composite-for-virtuals) (child virtual-window)
				&key)
  (with-slots (virtual-count) self
    (decf virtual-count)))

;;; 02/08/1991 (Matthias) 
;;; The following is needed to identify virtual windows
;;;

(defmethod query-pointer-most-specific ((self composite-for-virtuals))
  (multiple-value-bind (x y same-screen-p child)
      (query-pointer self)
    (declare (ignore same-screen-p))
    (if child
	(query-pointer-most-specific child)
	(or (event-virtual-child-x-y self x y) self))))


;;; The following allows virtuals to be stored in data-structures 
;;; separate from the CHILDREN slot (e.g using quad-trees to enhance 
;;; access to virtuals located in a specific region).
;;; Note: to keep the data-structure consistent with the CHILDREN slot
;;; you have to provide add/delete-child demons!
;;;
(defmethod map-over-virtuals ((self composite-for-virtuals) region predicate function
			      &rest args)
  "Apply FUNCTION to SELF's virtual children satisfying PREDICATE (or to all if nil) and 
   which are located inside region (or to all if region is nil). 
   The default method tests region intersection by virtual's IN-REGION-P method."
  (declare (type (or null region) region))
  (with-slots (virtual-count) self
    (unless (zerop virtual-count)
      (dolist (child (composite-children self))
	(when (and (typep child 'virtual-window)
		   (or (null predicate)
		       (funcall predicate child))
		   (or (null region)
		       (in-region-p child region)))
	  (apply function child args))))))

;;; 
;;; Redisplaying virtuals
;;;

(defmacro with-final-update-of-virtuals (window &body body)
  "Prevent update operations on window's virtuals during execution of BODY.
   Afterwards the window's area is cleared and an exposure event for that 
   area generated.
   Moreover, any exposure events dispatched to the window inside BODY
   (e.g. by changing geometry of real children ...) are thrown away in order
   to prevent obsolete update actions.
   This macro may be nested, i.e. called again inside BODY. In this case
   only the outermost occurence does the side effects described above."
  `(with-final-update-of-virtuals-internal ,window #'(lambda () .,body)))

(defun with-final-update-of-virtuals-internal (window continuation)
  (with-slots (update-virtuals? disable-exposures?) window
    (let ((saved-update-virtuals? update-virtuals?))
      (unwind-protect
	  (progn
	    ;; inform the HANDLE-EVENT method to disable exposures from now on
	    (setf disable-exposures? t		
		  update-virtuals? nil)
	    (funcall continuation))
	(setf update-virtuals? saved-update-virtuals?)
	(when saved-update-virtuals?	; skip update for nested calls 
	  (cond ((realized-p window)
		 (clear-area window)
		 ;; Generate an exposure event for the cleared area.
		 ;; This event informs the HANDLE-EVENT method to enable
		 ;; exposures again!
		 ;; Note: this event is distinguished from ordinary exposure events
		 ;; by the send-event-p event-slot.
		 (with-slots (width height) window
		   (send-event window :exposure nil
			       :x 0 :y 0 :width width :height height :count 0
			       :event-window window :window window)))
		(t
		 
		 ;; If the window is currently not realized, we have to
		 ;; enable exposures for ourselves.
		 (setf disable-exposures? nil)
		 )))))))

(defmethod update ((self composite-for-virtuals))
  (when (and (realized-p self) (not (destroyed-p self)))
    (before-display self)
    ;; first update children (including virtuals)
    (dolist (child (composite-children self))
      (update child))
    ;; then self (this order is needed for inverse? to work correctly)
    ;; (drawback: the primary display method is never called!)
    (after-display self)))

(defmethod update-for-virtuals-needed ((self composite-for-virtuals) virtual region)
  "Update (i.e. redisplay) virtuals that may have been damaged by an operation on VIRTUAL.
   REGION is the enclosing region of VIRTUAL."
  (with-slots (update-virtuals?) self
    (when update-virtuals?
      (map-over-virtuals self region #'mapped-p
			 #'(lambda (v)
			     (or (eq v virtual)	    ; don't update VIRTUAL now!
				 (update v)))))))


;;; ToDo: [Hubertus 7/19/90]
;;; Implement a priority ordering among overlapping virtuals
;;; that may be specialized or changed. Up to now redisplay 
;;; of virtuals is controlled by the map-over-virtuals function 
;;; which simply redisplays virtuals according to their position 
;;; in composite's children slot in a `first come, first displayed' 
;;; manner, i.e. the ordering is fixed at instantiation time.

;;;
;;; Maintaining composite's event-mask
;;;

(defmethod realize :before ((self composite-for-virtuals))
  (update-event-mask self))

(defmethod update-event-mask ((self composite-for-virtuals) &optional new-virtual)
  (with-slots (virtual-count) self
    (unless (zerop virtual-count)
      (with-accessors ((composite-event-mask contact-event-mask)) self
	(let ((event-mask 0))
	  (if new-virtual
	      (setq event-mask (contact-event-mask new-virtual))
	      ;; Combine the event masks for the virtual children
	      (map-over-virtuals self nil nil
		#'(lambda (virtual)
		    (setq event-mask (logior event-mask (contact-event-mask virtual))))))
	  ;; Select pointer-motion when enter/leave window is needed
	  (when (plusp (logand event-mask #.(make-event-mask :enter-window :leave-window)))
	    (setq event-mask (logior event-mask #.(make-event-mask :pointer-motion))))
	  ;; Combine virtual event mask(s) with the composite's
	  (setf composite-event-mask (logior event-mask composite-event-mask)))))))

;;;
;;;  Event Handling
;;;

(defmethod event-virtual-child ((self composite-for-virtuals) event)
  (let ((x (slot-value (the event event) 'x))
	(y (slot-value (the event event) 'y)))
    (event-virtual-child-x-y self x y)))

(defmethod event-virtual-child-x-y ((self composite-for-virtuals) x y)
    (block nil 
      (map-over-virtuals
	self nil #'mapped-p
	#'(lambda (child)
	    (with-slots ((contact-x x) (contact-y y)) child
	      (when (inside-contact-p child (- x contact-x) (- y contact-y))
		(return child)))))
      nil))


;;; An Event Handler for virtuals:
;;;
;;; HANDLE-EVENT has been extended to manage virtual children too.
;;; It takes care to forward events to virtuals, thereby managing
;;; interactions between virtuals, the composite and its real children. 
;;; It also features an optimized exposure event handling for virtuals.
;;;
(defmethod handle-event ((contact composite-for-virtuals) (event event)) 
  ;; Do event/callback translation based on the event-translations slot
  (with-slots (virtual-count exposure-by-region? disable-exposures?) contact
    (if (zerop virtual-count)
	(with-slots (key send-event-p) (the event event)
	  ;; take care to skip and reenable exposures
	  (when (and (eq key :exposure)
		     disable-exposures?)
	    (if send-event-p
		(setf disable-exposures? nil)
		(return-from handle-event nil)))
	  (call-next-method))
	(block exit
	  (let ((event-key (slot-value (the event event) 'key))
		(event-sequence (slot-value (the event event) 'sequence)))
	    ;; Handle universal events
	    (case event-key
	      ;; Forward events to virtual children
	      ((:key-press :key-release :button-press :button-release)
	       (let ((child (event-virtual-child contact event)))
		 (with-slots ((child-x x) (child-y y)
			      (child-event-mask event-mask)) (the virtual-window child)
		   (with-slots ((event-x x) (event-y y)
				(event-key key) (event-kind kind)
				(event-child child)) (the event event)
		     (when
		       (and child
			    (plusp
			      (logand child-event-mask
				      (case event-key
					(:key-press #.(make-event-mask :key-press))
					(:key-release #.(make-event-mask :key-release))
					(:button-press #.(make-event-mask :button-press))
					(:button-release #.(make-event-mask :button-release))))))
		       ;; Make event relative to child
		       (setf event-x (- event-x child-x)
			     event-y (- event-y child-y))
;		       (format t "~%key ~s dispatched to ~s" event child)
		       (cluei::dispatch-event event event-key t event-sequence child)
		       ;; if event's actions changed virtual's contact-state to unmapped
		       ;; reset the mouse-contact slot and send an appropriate
		       ;; enter-notify event to the parent or a real child.
		       (unless (mapped-p child)
			 (setf (mouse-contact contact) nil)
			 (setf event-key :enter-notify
			       event-kind (if event-child :ancestor :inferior))
			 (cluei::dispatch-event event :enter-notify t event-sequence
						       (or event-child contact)))
		       (return-from exit nil))))))
	  
	      ;; fabricate mouse enter/leave for virtual children unless
	      ;; the event comes from a real child (that doesn't handle :motion-notify
	      ;; itself)
	      (:motion-notify
		(unless (slot-value event 'child)   
		  (let ((child (event-virtual-child contact event)))
		    (if child
			;; Take care to set the KIND event field
			;; for :enter/:leave-notify events to :nonlinear!
			;; (MODE and FOCUS fields remain uninitialized)
			(let ((mouse-contact (mouse-contact contact))
			      (handled-p nil)
			      (x (slot-value (the event event) 'x))
			      (y (slot-value (the event event) 'y)))
			  (with-slots ((child-x x) (child-y y)
				       (child-event-mask event-mask)) (the virtual-window child)
			    (with-slots ((mouse-x x) (mouse-y y)
					 (mouse-event-mask event-mask)) (the virtual-window mouse-contact)
			      (with-slots ((event-x x) (event-y y)
					   (event-key key) (event-kind kind)) (the event event)
				(when (and mouse-contact (not (eq mouse-contact child))
					   (plusp (logand #.(make-event-mask :leave-window)
							  mouse-event-mask)))
				  ;; Make event relative to child
				  (setf event-x (- x mouse-x)
					event-y (- y mouse-y)
					event-kind :nonlinear)
;				  (format t "~%motion-notify LEAVE for ~s" mouse-contact)
				  (cluei::dispatch-event event :leave-notify t event-sequence mouse-contact)
				  (setq handled-p t))
				;; fabricate :leave-notify :inferior for parent
				(unless mouse-contact				  
				  (setf event-x x
					event-y y
					event-kind :inferior)
;				  (format t "~%motion-notify LEAVE INFERIOR for ~s" contact)
				  (cluei::dispatch-event event :leave-notify t event-sequence
							 contact))
				(setf (mouse-contact contact) child)
				(when (and (not (eq mouse-contact child))
					   (plusp (logand #.(make-event-mask :enter-window)
							  child-event-mask)))
				  (setf event-x (- x child-x)
					event-y (- y child-y)
					event-kind (if mouse-contact :nonlinear :ancestor))
;				  (format t "~%motion-notify ENTER for ~s" child)
				  (cluei::dispatch-event event :enter-notify t event-sequence child)
				  (setq handled-p t))
				(when (plusp (logand #.(make-event-mask
							 :pointer-motion :pointer-motion-hint
							 :button-1-motion :button-2-motion :button-3-motion
							 :button-4-motion :button-5-motion :button-motion)
						     child-event-mask))
				  (setf event-x (- x child-x)
					event-y (- y child-y))
;				  (format t "~%motion-notify MOTION-NOTIFY for ~s" child)
				  (cluei::dispatch-event event :motion-notify t event-sequence child)
				  (setq handled-p t))
				(when handled-p (return-from exit nil))
				(setf event-x x
				      event-y y
				      event-key :motion-notify)))))	; restore event-key
			;; don't forget to fabricate :leave-notify for virtual 
			;; and an :enter-notify :inferior/:ancestor for parent/child 
			;; if pointer moved from virtual into parent or child
			(let ((mouse-contact (mouse-contact contact))
			      (x (slot-value (the event event) 'x))
			      (y (slot-value (the event event) 'y))
			      (handled-p nil))
			  (with-slots ((mouse-x x) (mouse-y y)
				       (mouse-event-mask event-mask)) (the virtual-window mouse-contact)
			    (with-slots ((event-x x) (event-y y)
					 (event-key key) (event-kind kind)
					 (event-child child))  (the event event)
			      (when (and mouse-contact 
					 (plusp (logand #.(make-event-mask :leave-window)
							mouse-event-mask)))
				;; Make event relative to child
				(setf event-x (- x mouse-x)
				      event-y (- y mouse-y)
				      event-kind :ancestor)
;				(format t "~%motion-notify LEAVE for ~s" mouse-contact)
				(cluei::dispatch-event event :leave-notify t event-sequence mouse-contact)
				(setf (mouse-contact contact) nil)
				(setq handled-p t))
			      (setf event-x x
				    event-y y)
			      (when mouse-contact
				;; fabricate :enter-notify :inferior/:ancestor for parent/child
				(setf event-kind (if event-child :ancestor :inferior))
;				(format t "~%motion-notify ENTER INFEROIR for ~s"
;					(or event-child contact))
				(cluei::dispatch-event event :enter-notify t event-sequence
						       (or event-child contact))
				(setq handled-p t))
			      (when handled-p (return-from exit nil))
			      (setf event-key :motion-notify))))))	; restore event-key!
		  ))

	      ;; When mouse leaves composite (possibly into a real child),
	      ;; fabricate leave-notify :ancestor for virtual
	      (:leave-notify
		(let ((mouse-contact (mouse-contact contact)))
		  (with-slots ((mouse-x x) (mouse-y y)
			       (mouse-event-mask event-mask)) (the virtual-window mouse-contact)
		    (with-slots ((event-x x) (event-y y)
				 (event-key key) (event-kind kind)) (the event event)
		      (when mouse-contact
			(setf (mouse-contact contact) nil)
			(when (plusp (logand #.(make-event-mask :leave-window)
					     mouse-event-mask))
			  ;; Make event relative to child
			  (setf event-x (- event-x mouse-x)
				event-y (- event-y mouse-y)
				event-kind :ancestor)
;			  (format t "~%leave-notify for mouse-contact ~s" mouse-contact)
			  (cluei::dispatch-event event :leave-notify t event-sequence mouse-contact)
			  (return-from exit nil)))))))
	      
	      ;; when mouse enters (possibly from a real child), check if inside a virtual
	      (:enter-notify
		(let ((child (event-virtual-child contact event))
		      (x (slot-value (the event event) 'x))
		      (y (slot-value (the event event) 'y)))
		  (with-slots ((event-x x) (event-y y)
			       (event-key key) (event-kind kind)) (the event event)
		    (with-slots ((child-x x) (child-y y)
				 (child-event-mask event-mask)) (the virtual-window child)
		      (when child
			(setf (mouse-contact contact) child)
			(when (plusp (logand #.(make-event-mask :enter-window)
					     child-event-mask))
			  (setf event-x (- x child-x)
				event-y (- y child-y)
				event-kind :nonlinear)
;			  (format t "~%motion-notify ENTER for ~s" child)
			  (cluei::dispatch-event event :enter-notify t event-sequence child)
			  (return-from exit nil)))))))

	      (:exposure
		(with-slots ((event-x x) (event-y y)
			     (event-width width) (event-height height)
			     send-event-p) (the event event)
		  (when disable-exposures?
		    (if send-event-p
			(setf disable-exposures? nil)
			(progn
;			  (format t "~%SKIPPING exposure: ~S: ~s ~s ~s ~s send-p: ~S"
;				  event event-x event-y event-width event-height
;				  (slot-value event 'send-event-p))
			  (return-from exit nil))))	; skip exposure event
;		  (format t "~%exposure: ~S: ~s ~s ~s ~s send-p: ~S"
;			  event event-x event-y event-width event-height
;			  (slot-value event 'send-event-p))
		  (let ((x event-x)
			(y event-y))
		    ;; handle display and other actions 
		    (call-next-method)
		    ;; before dispatching exposure events for virtuals
		    ;; we have to reset the event-count to 0 (multiple 
		    ;; exposure events have already been handled by (call-next-method))
		    ;, otherwise we get stuck in the dispatch to the first virtual
		    ;; waiting for more exposure events to follow!
		    (setf (slot-value event 'cluei::count) 0)
		    ;; dispatch exposure events to virtual children
		    (map-over-virtuals
		      contact
		      ;; restrict exposure for virtuals to exposure-region
		      ;; if EXPOSURE-BY-REGION? is non-NIL.
		      ;; In oder to work with EXPOSURE-BY-REGION? set to T, you must
		      ;; ensure that the actions performed by exposure events
		      ;; (i.e. display) do not CLEAR contact's area.
		      (and exposure-by-region?
		      	   (region event-x event-y event-width event-height))
		      #'mapped-p
		      #'(lambda (child)
			  (with-slots ((child-x x) (child-y y))
				      (the virtual-window child)
			    (setf event-x (- x child-x)
				  event-y (- y child-y)))
;		          (format  t "~%exposure dispatch to ~s ~s count: ~S"
;			   child event-sequence (slot-value event 'cluei::count))
			  (cluei::dispatch-event event :exposure t event-sequence child)))
		    (setf event-x x
			  event-y y))
		  ;; and return 
		  (return-from exit nil)))
	      )

;	    (format t "~%calling next method for ~s" event-key)
	    (call-next-method)))
	)))

