;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT; -*-
;;;__________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Window
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/window.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 10/08/92 13:52:43
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 6/11/90 (Juergen)  basic-window's superclass changed to basic-contact
;;;
;;; 6/11/90 (Juergen)  class scrollable-window-mixin introduced as superclass
;;;                    of basic-window
;;;
;;; 7/17/90 (Hubertus) fixed bug in rubberbanding code.
;;;
;;; 7/21/90 (Hubertus) modified BOUNDING-BOX to include managed children only!
;;;
;;; 7/22/90 (Hubertus) added a BOUNDING-SIZE method that may be specialized.
;;;
;;; 7/29/90 (Hubertus) added a new version for MOVE-WINDOW-WITH-MOUSE.
;;;
;;; 9/07/90 (Kalle)    deleted the new version for MOVE-WINDOW-WITH-MOUSE
;;;                    again (it won't run under CLUE 7.20)
;;;
;;; 11/12/90 (Matthias) changed: move-window-with-mouse
;;;                     former definition will still be used as old-move-...
;;;                     in newsize-window-with-mouse
;;;
;;; 11/26/1990 (Matthias) 4 different moves can be chosen by parameter
;;;                       *move-window-with-mouse-type*: :wire, :fast
;;;                       :nice, :old,
;;;                       move-window can be called now interactively again
;;;
;;; 01/03/1991 (Juergen)   update method moved from basic-window
;;;                        to basic-contact (or contact)
;;;
;;; 01/03/1991 (Juergen)   refresh-window now performs an update,
;;;                        redisplay-window does what refresh-window did 
;;;                        formerly, e.g. it does not update subwindows.
;;; 
;;; 01/25/1991 (Juergen)   basic-window has got a new slot layouted?, which
;;;                        specifies, whether a window should be layouted
;;;                        by its parent window. Default is nil.
;;;                        Layouted? is initialized with t if no x or y 
;;;                        coordinate is specified (cf. function make-window).
;;;
;;; 01/25/1991 (Juergen)   New method layouted-p for basic-windows which tests
;;;                        whether a window is layouted? and managed-p
;;;
;;; 01/25/1991 (Juergen )  New functions next-layouted-sibling, 
;;;                        previous-layouted-sibling, first-layouted-sibling,
;;;                        last-layouted-sibling, 
;;;                        next-layouted-sibling-rotated, 
;;;                        previous-layouted-sibling-rotated
;;;
;;; 03/12/1991 (Juergen)   change-window-border has been changed to set the 
;;;                        border-color of the window instead of the
;;;                        border-width! 
;;;                        Use new method change-window-border-width instead!
;;;
;;; 05/29/1991 (Juergen)   New value :filled for *move-window-with-mouse-type*
;;;                        which should replace value :nice.
;;;
;;; 05/29/1991 (Juergen)   The following methods were specialized on contact
;;;                        and are now specialized on basic-contact instead:
;;;                        change-window-width, change-window-height, 
;;;                        refresh-window, redisplay-window, 
;;;                        change-window-border-width
;;; 05/31/1991 (Hubertus)  moved UPDATE method from layouted-window to 
;;;                        composite.
;;;
;;; 06/04/1991 (Juergen)   New methods change-window-x and change-window-y
;;;                        (for completeness)
;;; 
;;; 10/24/1991 (Hubertus)  New method enclosing-region for basic-contacts
;;;                        (to be specialized by virtual-windows).
;;;
;;; 10/28/1991 (Hubertus)  New method IN-REGION-P for basic-contacts.
;;;
;;; 10/28/1991 (Hubertus)  New method CHILDREN-IN-REGION for composites.
;;;
;;; 10/24/1991 (Hubertus)  Reimplemented method RESIZE-WINDOW-WITH-MOUSE
;;;                        which now includes the functionality of 
;;;                        NEWSIZE-WINDOW-WITH-MOUSE. 
;;; 12/19/1991 (Matthias)  new generic: adjusted-window-size
;;;                        new: adjusted-total-width and -height
;;;                        new: fixed-size-mixin for efficency
;;; 02/13/1992 (Matthias)  new: totop-or-tobottom-window
;;;
;;; 03/04/1992 (Juergen)   Method toplevel-window moved from basic-window to
;;;                        basic-contact 
;;;
;;; 03/18/1992 (Juergen)   inside-border has become a resource slot
;;;
;;; 04/09/1992 (Juergen)   New function make-gio which can/should be used 
;;;                        for creating arbitrary kinds of interaction objects
;;;                        For window classes make-window is called, otherwise
;;;                        make-instance is used.  Therefore make-gio also
;;;                        works for non-window objects, e.g. layouters,
;;;                        sound-dispels, etc.
;;;                        make-gio may also be used to create input-output
;;;                        or input-only windows with create-window.  For this,
;;;                        input-output-window or input-only-window have to
;;;                        be specified as the class name.
;;; 07/21/1992 (Matthias)  New destroy method for basic-contact to get rid
;;;                        of them
;;; 08/03/1992 (Matthias)  Removed adjust-total-* methods for fixed-size-mixin
;;;                        If this makes no problems the mixin may be removed
;;;                        completely.
;;; 08/04/1992 (Matthias)  Moved get-pixel-name into this file cause it now
;;;                        needs a contact to access some colormap.
;;;__________________________________________________________________________

(in-package :xit)

;;____________________________________________________________________________
;;
;;                         Basic Contact Operations
;;____________________________________________________________________________

(defmethod destroy ((self basic-contact))
  (with-slots (parent) self
    (delete-child parent self)))

(defmethod update ((self basic-contact))
  (when (and (realized-p self) (not (destroyed-p self)))
    (display self)))

(defmethod update ((self composite))
  (when (and (realized-p self) (not (destroyed-p self)))
    ;; first update children
    (dolist (child (composite-children self))
      (update child))
    ;;then self (this order is needed for inverse? to work correctly)
    (display self)))

(defmethod x-offset ((self basic-contact) (one-parent basic-contact))
  "computes the x-offset relative to a composite in the parent hierarchy"
  (if (eq self one-parent) 0
    (when (ancestor-p self one-parent)
	  (with-slots (x parent) self
		      (cond ((eq parent one-parent) x)
			    (t (+ x (x-offset parent one-parent))))))))


(defmethod y-offset ((self basic-contact) (one-parent basic-contact))
  "computes the y-offset relative to a composite in the parent hierarchy"
  (if (eq self one-parent) 0
    (when (ancestor-p self one-parent)
	  (with-slots (y parent) self
		      (cond ((eq parent one-parent) y)
			    (t (+ y (y-offset parent one-parent))))))))

;;; NEW
;;;
(defgeneric adjusted-window-size (window)
  (:documentation
   "Returns two values: the WIDTH and HEIGHT that the window would normally 
   take to display its contents.")) 

(defmethod adjusted-window-size ((self basic-contact))
  ;; Default adjusted-window-size is current size of window
  (values (contact-width self) (contact-height self)))

(defmethod adjusted-total-width ((self basic-contact))
  (multiple-value-bind (w h)
      (adjusted-window-size self)
      (declare (ignore h))
    (+ (* 2 (contact-border-width self)) w)))

(defmethod adjusted-total-height ((self basic-contact))
  (multiple-value-bind (w h)
      (adjusted-window-size self)
      (declare (ignore w))
    (+ (* 2 (contact-border-width self)) h)))

(defcontact fixed-size-mixin ()
  ())

#|| Obsolete and dangerous. adjusted-total-width and contact-total-width
of, e.g., a text dispel in a paned window can differ purposely if the 
size is given as (:ask <self> 5), i.e. make mys real size 5 pixels larger than
my normal adjusted size.

(defmethod adjusted-total-width ((self fixed-size-mixin))
  (contact-total-width self))

(defmethod adjusted-total-height ((self fixed-size-mixin))
  (contact-total-height self))
||#


(defmethod contact-end-x ((self basic-contact))
  (with-slots (x width border-width) self
    (+ x width border-width border-width)))

(defmethod contact-end-y ((self basic-contact))
  (with-slots (y height border-width) self
    (+ y height border-width border-width)))


(defmethod contact-upper-left ((self basic-contact))
  (point (contact-x self) (contact-y self)))

(defmethod contact-lower-right ((self basic-contact))
  (point (contact-end-x self) (contact-end-y self)))

(defmethod contact-total-width ((self basic-contact))
  (with-slots (width border-width) self
    (+ width border-width border-width)))

(defmethod contact-total-height ((self basic-contact))
  (with-slots (height border-width) self
    (+ height border-width border-width)))

(defmethod enclosing-region ((self basic-contact) &optional
			     parent-relative-p return-values) 
  (declare (values (or null region
		       (values region-x region-y region-width region-height))))
  
  "Returns region (or coordinates of region) relative to parent origin or
   (inside) origin of SELF that encloses the contact.
   For non-specialized virtual windows the enclosing region is the contact's
   extent. 
   For virtuals the enclosing region is the display-area. Since this is used 
   for redisplay and intersection operations, the region need not be the
   smallest possible."
  
  (with-slots (x y width height border-width) self
    (funcall (if return-values #'values #'region)
	     (if parent-relative-p x (- border-width))
	     (if parent-relative-p y (- border-width))
	     (+ width border-width border-width)
	     (+ height border-width border-width))))

(defmethod in-region-p ((self basic-contact) region)
  "Returns T if SELF intersects with region."
  (multiple-value-bind (reg-x reg-y reg-w reg-h) (enclosing-region self T T)
    (and (< reg-x (region-endx region))
	 (> (+ reg-x reg-w) (region-x region))
	 (< reg-y (region-endy region))
	 (> (+ reg-y reg-h) (region-y region)))))


(defun next-layouted-sibling (window &optional (relative-to (contact-parent window)))
  "Return the first layouted window after window"
  (dolist (sibling (cdr (member window
				(layouted-parts relative-to)
				:test #'eq)))
    (when (layouted-p sibling) (return sibling))))

(defun previous-layouted-sibling (window &optional (relative-to (contact-parent window)))
  "Return the first layouted window before window"
  (let ((previous nil))
    (dolist (sibling (layouted-parts relative-to))
      (when (eq sibling window) (return previous))
      (when (layouted-p sibling) (setq previous sibling)))))

(defun first-layouted-sibling (window &optional
				      (relative-to (contact-parent window)))
  "Return the first layouted sibling"
  (dolist (sibling (layouted-parts relative-to))
    (when (layouted-p sibling) (return sibling))))

(defun last-layouted-sibling (window &optional
				     (relative-to (contact-parent window)))
  "Return the last layouted sibling"
  (let ((last nil))
    (dolist (sibling (layouted-parts relative-to))
      (when (layouted-p sibling) (setq last sibling)))
    last))

(defun next-layouted-sibling-rotated (window &optional
					     (relative-to (contact-parent window)))
  (or (next-layouted-sibling window relative-to)
      (first-layouted-sibling window relative-to)))

(defun previous-layouted-sibling-rotated (window &optional
					  (relative-to (contact-parent window)))
  (or (previous-layouted-sibling window relative-to)
      (last-layouted-sibling window relative-to)))

(defmethod resize-window ((self basic-contact) &optional width height)
  (if (and width height)
      (resize-window-absolute self width height)
      ; width and height of a contact have to be positive
      (resize-window-interactively self)))

(defmethod resize-window-absolute ((self basic-contact) width height)
  (change-geometry self :width (max width 1) :height (max height 1)))

(defmethod resize-window-interactively ((self basic-contact))
  (resize-window-with-mouse self))

(defmethod newsize-window ((self basic-contact) &optional x y width height)
  (if (and x y width height)
      (change-geometry self :x x :y y :width (max width 1) :height (max height 1))
      (resize-window-with-mouse self)))

(defmethod refresh-window ((self basic-contact))
  (update self))

(defmethod redisplay-window ((self basic-contact))
  (when (and (realized-p self) (not (destroyed-p self)))
    (display self)))

(defmethod totop-window ((self contact))
  (change-priority self :above)
  (setf (contact-state self) :mapped))

(defmethod totop-or-tobottom-window ((self contact))
  (change-priority self :opposite)
  ;(setf (contact-state self) :mapped) ;; makes no sense here
  )

(defmethod tobottom-window ((self contact))
  (change-priority self :below))

(defmethod bury-window ((self contact))
  (setf (contact-state self) :managed))

(defmethod change-window-x ((self basic-contact) x)
  (change-geometry self :x x))

(defmethod change-window-y ((self basic-contact) y)
  (change-geometry self :y y))

(defmethod change-window-width ((self basic-contact) width)
   ; width of a contact has to be positive
  (change-geometry self :width (max width 1)))

(defmethod change-window-height ((self basic-contact) height)
   ; height of a contact has to be positive
  (change-geometry self :height (max height 1)))

(defmethod change-window-border-width ((self basic-contact) width)
  (change-geometry self :border-width width))

(defmethod change-window-border ((self contact) color)
  (setf (window-border self)
      (convert self color '(or (member :copy) pixel pixmap))))

(defmethod change-window-background ((self contact) background)
  ;;[Juergen  Tue Nov  6 09:39:12 1990] background is converted automatically
  (setf (contact-background self) background)
  (clear-area self :exposures-p t))

(defmethod change-window-cursor ((self contact) cursor)
  (setf (window-cursor self) (convert self cursor 'cursor)))

(defmethod contact-clipmask ((self contact))
  nil)

(defmethod flash-window ((self contact) &optional (sleep-seconds 0.3))
  (with-slots (width height display) self
    (using-gcontext (gc :drawable self :function BOOLE-XOR
			:foreground *inversion-pixel*
			:subwindow-mode :include-inferiors
			:clip-mask (contact-clipmask self)) 
      (draw-rectangle-inside self gc 0 0 width height t)
      (display-force-output display)
      (sleep sleep-seconds)
      (draw-rectangle-inside self gc 0 0 width height t)
      (display-force-output display)
      )))

(defmethod contact-colormap ((self contact))
  "Returns a colormap, even if contact is not yet realized."
  (if (realized-p self)
      (window-colormap self)
    (window-colormap (contact-root self))))

(defmethod get-pixel-name ((self contact) pixel)
  "Return the name of the (next) color that is represented by PIXEL in the
   colormap of contact SELF."
  (if (numberp pixel)
      (let* ((colormap (contact-colormap self))
	     (color (car (query-colors colormap (list pixel)))))
	(get-color-name color))
  (case pixel
    (:none "none")
    (:parent-relative "transparent")
    (t (convert-to-readable-string pixel)))))

(defparameter *move-window-with-mouse-type* :wire)
(defparameter *move-window-with-mouse-drag* t)
(defparameter *move-window-with-mouse-in-bounds* nil)

;;; [Matthias  Tue Nov 27 10:21:03 1990]
;;; discard-but-last-motion-event does what it says
;;; do not discard given events
;;; returns t if events have been discarded actually.

(defmethod discard-but-last-motion-event ((self basic-contact) do-not-discard-events)
  "Perform motion compression:   
   Count consecutive :motion-notify's currently in queue"
  (with-slots (display parent) self
    (let ((count 0) (count-of-event-to-keep 0))
      (event-case (display :force-output-p nil :peek-p t :timeout 0)
		  (:motion-notify (window)
				  (cond ((eq window parent)
					 (incf count)
					 (setq count-of-event-to-keep
					   count)
					 nil)
					(t t)))
					; was ((not (and (eq window parent) (incf count))))
		  (otherwise (event-key)
			     (incf count)
			     (cond ((member event-key do-not-discard-events)
				    (setq count-of-event-to-keep
				      count)
				    t)
				   (t nil))))
      (cond ((plusp count-of-event-to-keep)
	     ;; Remove all but last return t
	     (do ((c (1- count-of-event-to-keep) (1- c)))
		 ((zerop c))
	       (event-case (display :timeout 0)
			   (otherwise ()   t)))
	     t)))))

(defmethod move-window-notify ((self basic-contact) x y
			       mouse-offset-x mouse-offset-y)
  "To be filled by subclasses."
  (declare (ignore x y mouse-offset-x mouse-offset-y))
  nil)

 
(defmethod resize-window-with-mouse ((self basic-contact))
  (with-slots (width height parent border-width) self
    (let ((region (enclosing-region self t)))
      (when (specify-region-with-mouse (toplevel-window self)
				       :confine-to parent
				       :resize-only? nil
				       :initial-region region
				       :minimum-width 1
				       :minimum-height 1
				       :line-style :solid
				       :line-width 2
				       :button-action :button-press)
	(decf (region-w region) (+ border-width border-width))
	(decf (region-h region) (+ border-width border-width))
	(resize-window-absolute self (region-w region) (region-h region))
	(move-window-absolute self (region-x region) (region-y region)))
      (values width height))))


;;; obsolete
;;; 
(defmethod newsize-window-with-mouse ((self basic-contact))
  (warn "NEWSIZE-WINDOW-WITH-MOUSE is obsolete and will be removed in
         future vesrions. Use RESIZE-WINDOW-WITH-MOUSE instead."))


(defmethod children-in-region ((self composite) region)
  (with-slots (children) self
     (remove-if-not #'(lambda (child)
			(in-region-p child region))
                    children)))

;;; for efficiency reasons this method may be specialized by subclasses
;;;
(defmethod bounding-box ((self composite))
  "Returns extent of window's managed children relative to window's origin."
  (declare (values min-x min-y max-x max-y))
  (flet ((minimax (child)
	   (multiple-value-bind (x y w h) (enclosing-region child T T)
	     (values x y (+ x w) (+ y h)))))
    (with-slots (children) self
      (let ((rest (member-if #'managed-p children)))
	(if rest
	    (multiple-value-bind (min-x min-y max-x max-y) (minimax (car rest))
	      (dolist (child (cdr rest))
		(with-slots (x y) child
		  (when (managed-p child)
		    (multiple-value-bind (x y ex ey) (minimax child)
		      (setq min-x (min x min-x)
			    min-y (min y min-y)
			    max-x (max ex max-x)
			    max-y (max ey max-y))))))
	      (values min-x min-y max-x max-y))
	  (values 0 0 0 0))))))

;;; for efficiency reasons this method may be specialized by subclasses
;;; 
(defmethod bounding-size ((self composite))
  "Returns width and height of self's bounding box."
  (declare (values bounding-box-width bounding-box-height))
  (multiple-value-bind (min-x min-y max-x max-y) (bounding-box self)
    (values (- max-x min-x) (- max-y min-y))))

(defmethod toplevel-window (self)
  nil)

(defmethod toplevel-window ((self basic-contact))
  (toplevel-window (contact-parent self)))

;____________________________________________________________________________
;
;                               Basic Window
;____________________________________________________________________________

(defcontact basic-window (basic-contact scrollable-window-mixin)
  ((name :initform :basic-window)
   (inside-border :accessor inside-border
		  :initarg :inside-border)
   (layouted?     :type boolean
		  :initform nil
		  :accessor layouted?
		  :initarg :layouted?)
   (compress-exposures :allocation :class :initform :on))
; (:default-initargs :parent *toplevel*) ; this is what is meant, but it doesn't work
  (:resources
   (border-width :initform 0)
   (inside-border :initform 0))
  (:documentation "Basic class for window objects"))

(defmethod x-margin ((self basic-window))
  (inside-border self))

(defmethod y-margin ((self basic-window))
  (inside-border self))

(defmethod x-margins ((self basic-window))
  (* (inside-border self) 2))

(defmethod y-margins ((self basic-window))
  (* (inside-border self) 2))

(defmethod layouted-p ((self basic-window))
  (with-slots (layouted?) self
    (and layouted? (managed-p self))))

;____________________________________________________________________________
;
;                              Window Creation
;____________________________________________________________________________

(defun make-window (classname &rest options)
  (declare (special *toplevel*))
  (let ((window-options options))
    ;; when no x and y coordinates are specified  the window will be layouted
    (unless (or (and (getf window-options :x)
		     (getf window-options :y))
	       (getf window-options :layouted?))
      (setq window-options (list* :layouted? t window-options)))
    ;; *toplevel* is the default parent
    (unless (getf window-options :parent)
      (setq window-options (list* :parent *toplevel* window-options)))
    (apply #'make-contact classname
	   window-options)))

(defmethod make-gio ((classname symbol) &rest options)
  (let ((window-constructor
	 (if (subtypep classname 'basic-contact)
	     #'make-window
	   #'make-instance)))
    (apply window-constructor classname options)))

(defmethod make-gio ((classname (eql 'input-output-window)) &rest options)
  (apply #'create-window :class :input-output options))

(defmethod make-gio ((classname (eql 'input-only-window)) &rest options)
  (apply #'create-window :class :input-only options))
	       
;___________________________________________________________________________
;
;                         Basic Window Scrolling Methods
;___________________________________________________________________________


(defmethod extent-size ((self basic-window))
  "Returns current width and height of window's extent."
  (with-slots (width height) self
     (values width height)))

(defmethod scroll-x-screenful ((self basic-window)
			       &optional (screenfulls 1))
  "Scroll amount of <screenfulls> horizontally.
   Positive (negative) values indicate scrolling right (left)."
  (with-slots (width) self
    (scroll-relative self (* width screenfulls) 0)))

(defmethod scroll-y-screenful ((self basic-window)
			       &optional (screenfulls 1))
  "Scroll amount of <screenfulls> vertically.
   Positive (negative) values indicate scrolling downwards (upwards)."
  (with-slots (height) self
    (scroll-relative self 0 (* height screenfulls))))


;__________________________________________________________________________
; 
;                       Moving Windows stuff
;__________________________________________________________________________

(defun center (windows)
  "Returns a point object representing the center point of the bounding box of 
  the given WINDOWS. The WINDOWS have to be sibblings. Otherwise the result is 
  undefined."
 (region-center (bounding-region windows)))

(defmethod bounding-region ((window basic-contact))
  (enclosing-region window t))

(defmethod bounding-region (windows)
   (if windows
      (if (cdr windows)
       (reduce #'region-union
	       (mapcar #'bounding-region
		       windows))
     (bounding-region (car windows)))
     (region 0 0 0 0)))

(defmethod copy-contents ((self basic-contact) gc destination dx dy)
  (totop-window self)
  (copy-area self gc 0 0 (contact-width self) (contact-height self)
	     destination dx dy))

(defmethod pixmap-of-window ((window basic-contact))
  (with-slots (width height border-width) window
  (let ((pixmap (create-pixmap :width (contact-total-width window)
			       :height (contact-total-height window)
			       :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
			     (contact-total-width window)
			     (contact-total-height window)
			     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 ((self basic-contact) &optional x y)
  (if (and x y)
      (move-window-absolute self x y)
   (move-window-interactively self)))

(defmethod move-window-absolute ((self basic-contact) x y)
  (change-geometry self :x x :y y))

(defmethod move-window-interactively ((self basic-contact))
  (move-children (contact-parent self) (list self)
       :mouse-documentation "Move window with mouse. Any key aborts."
       :mouse-position :warp))		      

(defmethod move-windows (windows &optional dx dy)
  (if (and dx dy)
      (move-windows-relative windows dx dy)
    (move-windows-interactively windows)))

(defmethod move-windows-interactively (windows)
  (when (consp windows)
   (move-children (contact-parent (car windows)) windows
		 :mouse-documentation "Move windows with mouse. Any key aborts."
		 :mouse-position :center)))

(defmethod move-children ((parent composite) windows &key
			  (mouse-documentation "Move children.")
			  mouse-position)
  (move-windows-with-mouse
       parent  windows
       :mouse-documentation mouse-documentation
       :abort-events '((:key-press * *))))

(defmethod move-window-relative ((self basic-contact) dx dy)
  (move-window-absolute self (+ dx (contact-x self)) (+ dy (contact-y self))))

(defmethod move-windows-relative (windows dx dy)
  (dolist (win windows)
    (move-window-relative win dx dy )))

(defmethod move-windows-with-mouse ((parent composite) windows
					     &key
					     (style *move-window-with-mouse-type*)
					     (mouse-position :warp)
					     (drag *move-window-with-mouse-drag*)
       					     (in-bounds-p
					      *move-window-with-mouse-in-bounds*)
					      constraint confine-to min-dx min-dy
					     max-dy max-dx mouse-documentation
					     abort-events cursor feedback?
					     test type)
  "Move WINDOWS according to STYLE."  
  (let* ((mindx min-dx) (maxdx max-dx) (mindy min-dy) (maxdy max-dy)
	 (fixed-x (eq constraint :vertical))
	 (fixed-y (eq constraint :horizontal))
	 (mouse-point (when (member mouse-position '(:current :warp))
				(multiple-value-bind (mouse-x mouse-y)
				    (query-pointer parent)
				  (point mouse-x mouse-y))))
	 (bounding-region (bounding-region windows))
	 (mouse-position (case mouse-position
			   (:current mouse-point)
			   (:center (center windows))
			   (:warp (point
				  (min (max (point-x mouse-point)
					    (region-x bounding-region))
				       (region-endx bounding-region))
				  (min (max (point-y mouse-point)
					    (region-y bounding-region))
				       (region-endy bounding-region))))
			   (:event (with-event (x y event-window)
				    (multiple-value-bind (parent-x parent-y)
					(contact-translate event-window x y parent)
				      (point parent-x parent-y))))
			   (t mouse-position))))
    (unless cursor
      (setq cursor
	  (cond (fixed-y "sb_h_double_arrow")
	    (fixed-x "sb_v_double_arrow")
	    (t "fleur"))))
    (when in-bounds-p
      (setq mindx (- (region-x bounding-region)))
      (setq mindy (- (region-y bounding-region)))
      (setq maxdx (- (contact-width parent)(region-endx bounding-region)))
      (setq maxdy (- (contact-height parent)(region-endy bounding-region)))
      (when min-dx (maxf mindx min-dx))
      (when min-dy (maxf mindy min-dy))
      (when max-dx (minf maxdx max-dx))
      (when max-dy (minf maxdy max-dy))
      (minf mindx 0)
      (minf mindy 0)
      (maxf maxdx 0)
      (maxf maxdy 0))
    (move-windows-with-style parent windows style mouse-position
			   :confine-to confine-to 
			   :drag drag :fixed-x fixed-x :fixed-y fixed-y
			   :min-dx mindx :min-dy mindy
			   :max-dy maxdy :max-dx maxdx
			   :mouse-documentation mouse-documentation
			   :cursor cursor
			   :abort-events abort-events
			   :feedback? feedback? :type type :test test)))
	     
(defmethod move-windows-with-style ((parent composite) windows (style (eql :filled))
				  mouse-position
				  &key drag fixed-x fixed-y confine-to abort-events
				  mouse-documentation max-dx max-dy min-dx min-dy
				  cursor
				  &allow-other-keys)
  (with-slots (display width height) parent
    ;;   (with-event ((mouse-offset-x x) (mouse-offset-y y)))
    (let* ((regions (mapcar #'bounding-region windows))
	   (total-region (reduce #'region-union regions :initial-value
				 (region 0 0 0 0)))
	   (pixmaps (mapcar #'pixmap-of-window windows))
	   (save-pixmap (create-pixmap :width width :height height :drawable parent
				       :depth (contact-depth parent)))
	   (aux-pixmap (create-pixmap :width width :height height :drawable parent
				       :depth (contact-depth parent)))
	   (x-pos 0) (x-old 0) (y-old 0)
	   (y-pos 0))
      (unwind-protect
	  (using-gcontext (gc :drawable parent
			      :subwindow-mode :include-inferiors)
	    (warp-pointer parent (point-x mouse-position) (point-y mouse-position))
	    ;; process-all-events is called to process pending mouse-leaves events
	    ;; caused by warp pointer; formerly has been called after unmap-window
	    ;; (see below).
	    ;(process-all-events display)
	    (waiting-for-token-event (parent)
	      (dolist (win windows)
	        (setf (contact-state win) :managed)))
	    ;(process-all-events display)
	    (copy-area parent gc 0 0 width height save-pixmap 0 0)
	    (copy-window-pixmaps parent gc regions pixmaps :x x-pos
				 :y y-pos)
	    (copy-area save-pixmap gc 0 0 width height aux-pixmap 0 0)
	    (dragging-mouse
		(parent :cursor (convert parent cursor 'cursor)
			:drag drag :optimize t
			:confine-to confine-to
			:mouse-documentation mouse-documentation
			:abort-events abort-events)
	      (:before ()
		       ;(display-force-output display)
		       )
	      (:dragged (x y)
		(setq x-old x-pos y-old y-pos)
		(unless fixed-x (setq x-pos (- x (point-x mouse-position))))
		(unless fixed-y (setq y-pos (- y (point-y mouse-position))))
		(when min-dx (maxf x-pos min-dx))
		(when min-dy (maxf y-pos min-dy))
		(when max-dx (minf x-pos max-dx))
		(when max-dy (minf y-pos max-dy))
		(copy-window-pixmaps aux-pixmap gc regions pixmaps :x x-pos
				     :y y-pos)
		(copy-area-region aux-pixmap gc (min x-pos x-old)
				  (min y-pos y-old) (abs (- x-pos x-old))
				  (abs (- y-pos y-old)) total-region parent)
		;restore aux-pixmap
		(copy-area-region save-pixmap gc (min x-pos x-old)
				  (min y-pos y-old) (abs (- x-pos x-old))
				  (abs (- y-pos y-old))
				  total-region aux-pixmap)
		(move-window-notify parent x-pos y-pos
				    (point-x mouse-position)
				    (point-y mouse-position)))
	      (:abort () (copy-area save-pixmap gc  0 0 width height parent 0 0))
	      (:after () (copy-area save-pixmap gc 0 0 width height parent 0 0)
		      (move-windows-relative windows x-pos y-pos)))
	    (dolist (win windows)
	      (setf (contact-state win) :mapped)))
	(free-pixmap save-pixmap)
	(free-pixmap aux-pixmap)
	(mapcar #'free-pixmap pixmaps)
	(values x-pos y-pos)))))
	

(defmethod move-windows-with-style ((parent composite) windows (style (eql :nice))
				    mouse-position &rest args)
  (apply #'move-windows-with-style parent windows :filled mouse-position args))


(defmethod draw-wires ((parent composite)
			       gc windows regions masks x-offset y-offset)
  (do ((windows windows (cdr windows))
       (regions regions (cdr regions))
       (masks masks (cdr masks)))
      ((null windows))
    (draw-wire (car windows) gc parent (car regions) (car masks) x-offset y-offset)))
	    
(defmethod draw-wire ((self basic-window) gc parent region  mask x-offset y-offset)
  (declare (ignore mask))
  (draw-rectangle-inside parent gc
			 (+ x-offset (region-x region))
			 (+ y-offset (region-y region))
			 (region-w region)
			 (region-h region)))

(defmethod draw-wire-mask ((self composite) (window basic-window))
  nil)

(defmethod move-windows-with-style ((parent composite) windows (style (eql :wire))
				    mouse-position
				    &key drag fixed-x fixed-y confine-to abort-events
				  mouse-documentation max-dx max-dy min-dx min-dy
				  cursor &allow-other-keys)
  (with-slots (display) parent
    ;;   (with-event ((mouse-offset-x x) (mouse-offset-y y)))
    (let* ((regions (mapcar #'bounding-region windows))
	   (masks (mapcar #'(lambda (win) (draw-wire-mask parent win)) windows))
	   (x-pos 0)
	   (y-pos 0))
      (using-gcontext (gc :drawable parent :subwindow-mode :include-inferiors
			  :function BOOLE-XOR :foreground *inversion-pixel*
			  :line-width 2)
	(warp-pointer parent (point-x mouse-position) (point-y mouse-position))
	(process-all-events display)
	(dragging-mouse
	      (parent :cursor (convert parent cursor 'cursor)
		      :drag drag :optimize t
		      :confine-to confine-to
		      :abort-events abort-events
		      :mouse-documentation mouse-documentation)
	    (:before () (draw-wires parent gc windows regions masks x-pos y-pos))
	    (:dragged (x y)
	          (draw-wires parent gc windows regions masks x-pos y-pos)
		  (unless fixed-x (setq x-pos (- x (point-x mouse-position))))
		  (unless fixed-y (setq y-pos (- y (point-y mouse-position))))
		  (when min-dx (maxf x-pos min-dx))
		  (when min-dy (maxf y-pos min-dy))
		  (when max-dx (minf x-pos max-dx))
		  (when max-dy (minf y-pos max-dy))
		  (draw-wires parent gc windows regions masks x-pos y-pos)
		  (move-window-notify parent x-pos y-pos
				     (point-x mouse-position)
				     (point-y mouse-position)))
	    (:abort () (draw-wires parent gc windows regions masks x-pos y-pos)
		    )
	    (:after () (draw-wires parent gc windows regions masks x-pos y-pos) 
		    (move-windows-relative windows x-pos y-pos)))
	  (values x-pos y-pos)))))

(defmethod move-windows-with-style ((parent composite) windows
				    (style (eql :rectangle))
				    mouse-position
				    &key drag fixed-x fixed-y confine-to abort-events
				  mouse-documentation max-dx max-dy min-dx min-dy
				  cursor &allow-other-keys)
  (with-slots (display) parent
    ;;   (with-event ((mouse-offset-x x) (mouse-offset-y y)))
    (let* ((regions (mapcar #'bounding-region windows))
	   (x-pos 0)
	   (y-pos 0))
      (using-gcontext (gc :drawable parent :subwindow-mode :include-inferiors
			  :function BOOLE-XOR :foreground *inversion-pixel*
			  :line-width 2)
	(warp-pointer parent (point-x mouse-position) (point-y mouse-position))
	(process-all-events display)
	  
	(dragging-mouse
	      (parent :cursor (convert parent cursor 'cursor)
		      :drag drag :optimize t
		      :confine-to confine-to
		      :abort-events abort-events
		      :mouse-documentation mouse-documentation)
	    (:before () (draw-rectangles-inside parent gc regions :x x-pos
			 :y y-pos))
	    (:dragged (x y)
	          (draw-rectangles-inside parent gc regions :x x-pos :y y-pos)
		  (unless fixed-x (setq x-pos (- x (point-x mouse-position))))
		  (unless fixed-y (setq y-pos (- y (point-y mouse-position))))
		  (when min-dx (maxf x-pos min-dx))
		  (when min-dy (maxf y-pos min-dy))
		  (when max-dx (minf x-pos max-dx))
		  (when max-dy (minf y-pos max-dy))
		  (draw-rectangles-inside parent gc regions :x x-pos :y y-pos)
		  (move-window-notify parent x-pos y-pos
				     (point-x mouse-position)
				     (point-y mouse-position)))
	    (:abort () (draw-rectangles-inside parent gc regions :x x-pos :y y-pos)
		    )
	    (:after () (draw-rectangles-inside parent gc regions :x x-pos :y y-pos) 
		    (move-windows-relative windows x-pos y-pos)))
	  (values x-pos y-pos)))))

(defmethod move-windows-with-style ((self composite) windows
				    (style (eql :drag-and-drop))
				    mouse-position
				    &key drag fixed-x fixed-y confine-to abort-events
				  mouse-documentation max-dx max-dy min-dx min-dy
				  cursor (feedback? t) test type &allow-other-keys)
  (with-slots (display) self
    ;;   (with-event ((mouse-offset-x x) (mouse-offset-y y)))
    (let* ((regions (mapcar #'bounding-region windows))
	   (masks (mapcar #'(lambda (win) (draw-wire-mask self win)) windows))
	   (predicate
	    (cond ((null type) test)
		  (test #'(lambda (win) (and (typep win type)
					     (funcall test win))))
		  (t #'(lambda (win) (typep win type)))))
	   (found-window nil)
	   (old-found-window nil))
      (multiple-value-bind (x-pos y-pos)
	  (contact-translate (contact-parent (car windows)) 0 0 self)
	(using-gcontext (gc :drawable self :subwindow-mode :include-inferiors
			    :function BOOLE-XOR :foreground *inversion-pixel*
			    :line-width 2)
	  (flet ((highlight-window (window)
		   (when (typep window 'basic-contact)
		     ;; 10/25/91 (Hubertus) changed for virtuals 
		     (multiple-value-bind (x y w h) (enclosing-region window t t)
		       (draw-rectangle-inside (contact-parent window) gc
					      x y w h)))))
	    (warp-pointer self (+ x-pos (point-x mouse-position))
			  (+ y-pos (point-y mouse-position)))
	    (process-all-events display)
	    (dragging-mouse
		(self :cursor (convert self cursor 'cursor)
		      :drag drag :optimize t
		      :confine-to confine-to
		      :abort-events abort-events
		      :mouse-documentation mouse-documentation)
	      (:before () (draw-wires self gc windows regions masks x-pos y-pos))
	      (:dragged (x y event-window)
		(draw-wires self gc windows regions masks x-pos y-pos)
		(unless fixed-x (setq x-pos (- x (point-x mouse-position))))
		(unless fixed-y (setq y-pos (- y (point-y mouse-position))))
		(when min-dx (maxf x-pos min-dx))
		(when min-dy (maxf y-pos min-dy))
		(when max-dx (minf x-pos max-dx))
		(when max-dy (minf y-pos max-dy))
		(draw-wires self gc windows regions masks x-pos y-pos)
		(when feedback?
		  (setq found-window
		      (query-find-most-specific-window
		       predicate (contact-root event-window)))
		  (when (not (eq found-window old-found-window))
		    (when old-found-window
		      (highlight-window old-found-window))
		    (when found-window
		      (highlight-window found-window)))
		  (setq old-found-window found-window))
		(move-window-notify self x-pos y-pos
				    (point-x mouse-position)
				    (point-y mouse-position)))
	      (:abort () (draw-wires self gc windows regions masks x-pos y-pos)
		      (setq found-window nil))
	      (:after (event-window)
		(draw-wires self gc windows regions masks x-pos y-pos)
		      (setq found-window
		    (query-find-most-specific-window
		     predicate (contact-root event-window)))))
	    (when feedback?
	      (when old-found-window
		(highlight-window old-found-window)))
	    (values x-pos y-pos found-window)))))))

(defun update-state-and-move (window)
  (with-slots (display) window
    (update-state display)
    (process-all-events display)
    (move-window window)
    window))
