;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Changes:
;;;
;;; 06-Sep-93 Clive Tong  Use special Map-Window-And-Wait for LispWorks
;;; 03-Aug-93 Mickish Destroyed drawables that have title bars when reparenting
;;; 28-Jul-93 Mickish Removed title bars when reparenting top-level windows
;;; 20-May-93 Mickish Fixed left-border-width for DECwindows
;;; 17-May-93  koz    On an exposure with count>0, just merge the exposed
;;;                   bbox into the window's win-update-info-exposed-bbox
;;;                   (so we get only one update call per exposure).
;;; 22-Apr-93 Mickish Added With-Cursor and With-HourGlass-Cursor
;;; 19-Apr-93 Mickish Added font-from-file and :CURSOR to Set-Window-Cursor
;;; 24-Mar-93  koz    Better window reparenting: rewrote fix-window-properties
;;;                   for slot :parent (also, create-x-drawable now sets
;;;                   the :old-parent slot of the window)
;;; 18-Jan-93 Mickish Added Change-Cursors and Restore-Cursors
;;; 16-Jan-93 Mickish In Fix-Window-Properties, compensate for border widths
;;;                   when setting :left and :top of windows; in delete-notify,
;;;                   destroy orphaned drawables when appropriate
;;;  4-Jan-93 Mickish Added checks for NIL drawables to event functions (like
;;;                   opal::Exposure) since opal:clean-up destroys drawables.
;;; 21-Dec-92 Mickish Added display-force-output calls to raise-window and
;;;                   lower-window; rewrote Set-Window-Cursor to reuse old
;;;                   xlib:cursor objects.
;;; 10-Dec-92 Mickish *drawable-to-window-mapping* ---> *garnet-windows*
;;; 28-Oct-92 hopkins In Initialize-Window-Border-Widths, changed border-width
;;;                   computations for TVTWM
;;; 22-Oct-92  koz    Added #'zoom-window and #'fullzoom-window
;;;  6-Oct-92  koz    Changed #'update-slot-invalidated to a g-value
;;;                   of opal:WINDOW :invalidate-demon
;;; 11-Sep-92 Duchier Changed "(4 6)" clauses in Configure-Notify and
;;;                   Initialize-Window-Border-Widths for tvtwm
;;; 24-Jun-92 Pervin  Add #-clx-cl-error test before xlib:drawable-root.
;;; 29-May-92 Pervin  Lispworks switch
;;; 27-May-92 Pervin  Added :save-under slot to windows.
;;; 18-May-92 Pervin  In configure-notify, check that windows are not destroyed.
;;; 13-May-92 Pervin  Only do map-window-and-wait if xlib:window-map-state
;;;		      of window is :unmapped.  Do map-window-and-wait in
;;;		      Allegro version 4 after all.
;;;  4-May-92 Almond  Allegro-v4.1 switches
;;; 29-Apr-92 Pervin  Reduced :timeout in map-window-and-wait to 5 sec.
;;;		      Only do wait in map-window-and-wait in Lucid and Allegro <4.0.
;;; 21-Apr-92 Pervin  Using new function main-event-loop-process-running-p
;;; 20-Apr-92 Pervin  Fixed minor bug in raise-window.
;;; 16-Apr-92 Pervin  At end of Configure-notify, do not update windows that have
;;;		      never been updated before. (see change of 6-Sep-90).
;;;		      Also, need special case for if xlib:query-tree doesn't work.
;;; 14-Apr-92 Pervin  Uncommented out process code.  Got multiprocess to work on HP.
;;;  8-Apr-92 Davis   In fix-window-properties, when changed slot is :aggregate,
;;;		      check that old-agg is not destroyed.
;;;  8-Apr-92 Pervin  On a black-and-white screen, draw background-color white
;;;		      except when background-color is actually opal:black.
;;; 31-Mar-92 Pervin  New :draw-on-children slot of window.
;;; 31-Mar-92 Szekely New :icon-bitmap slot of window holds pixmap of icon.
;;; 30-Mar-92 Pervin  Temporarily commenting out process code.
;;; 25-Mar-92 Pervin  Make default-event-handler be only defined in i-windows.lisp.
;;;		      Use switch #+clx-cl-error to check for query-tree bug.
;;; 20-Mar-92 Pervin  Use launch-main-event-loop-process.
;;; 19-Mar-92 Mickish Bound a-window-update-info in :initialize method for
;;;                   windows to eliminate CMUCL compiler warnings
;;; 18-Mar-92 Pervin  Map-window-and-wait no longer needed now that we
;;;		      have main event loop process.
;;; 11-Mar-92 Pervin  New width and height fields of win-update-info.
;;;  5-Mar-92 Pervin  If a window is iconified before it is first updated,
;;;		      its initial state should be :iconic.
;;;		      Also, should use xlib:withdraw-window, not xlib:unmap-window
;;; 27-Feb-92 Pervin  Added deiconify-window.
;;; 19-Feb-92 Pervin  Implemented double-clip-mask as list of length 8.
;;; 11-Feb-92 Pervin  Vastly simplified expand-buffer to just create new buffer
;;; 03-Jan-92 Mickish Changed to call with-demon-disabled.
;;; 31-Jan-92 Pervin  Eliminated *display-name-to-display-mapping*.
;;;		      Rewrote initialize-display to take no arguments,
;;;		      and always set display-info-display to be default.
;;;		      This was needed for conversion to CMUCL.
;;; 23-Jan-92 Pervin  Call *exit-main-event-loop-function* instead of throwing
;;;                   exception.
;;; 21-Jan-91 Pervin  Remove subwindow from parent when it is destroyed.
;;;  9-Jan-91 Pervin  Map-window-and-wait routine.
;;; 16-Dec-91 Pervin  Removed the section of Exposure that merged several
;;;		      exposure events.
;;;  9-Dec-91 Pervin  opal-gc has new stored-clip-mask field
;;;  5-Dec-91 Pervin  In Exposure, do not re-update window that has been
;;;                   exposed for the very first time.
;;; 26-Nov-91 Pervin  changed clear-buffer to correctly handle double-buffered
;;;		      windows with background color.
;;; 25-Nov-91 koz     changed fix-properties method to fix-window-properties
;;;                   function and altered # of args to it (it's only called
;;;                   from within update-windows, and this is more efficient)
;;; 18-Nov-91 Pervin  Added :background-color to windows.
;;;  5-Nov-91 Irwin   You may now destroy a window using f.delete or f.kill.
;;;		      Also, a window can have :min-width, :min-height,
;;;		      :max-width, and :max-height.
;;; 24-Oct-91 Pervin  Exit main-event-loop automatically if no windows visible
;;;                   Also :visible is set to :iconified if you iconify by hand
;;;  9-Oct-91 Szekely Fixed OpenWindows bug in Configure-notify.
;;; 25-Jun-91 Meltsner  Fixed :lineage of DECWindows.
;;;  7-Jun-91 Pervin  Added kr:with-demons-disabled inside map-notify and
;;;		      unmap-notify.
;;; 30-May-91 Pervin  Fixed bug so window will not de-iconify if you
;;;		      call inter:main-event-loop after calling iconify-window.
;;;  4-Apr-91 Pervin  New slot :omit-title-bar-p for windows.
;;; 18-Mar-91 Pervin  Xlib:query-tree seems to have been fixed in
;;;		      Allegro Version 4.0.
;;; 21-Feb-91 Pervin  New exported routine iconify-window.
;;; 31-Jan-91 Pervin  In fix-properties, when a window is made visible,
;;;                   call xlib:map-window last.
;;; 12-Nov-90 Pervin  Made first argument to convert-coordinates optional.
;;;  9-Nov-90 Pervin  Made second argument to convert-coordinates optional.
;;; 31-Oct-90 Pervin  Finally added convert-coordinates, which I'd
;;;                   forgotten before.
;;; 29-Oct-90 Pervin  Fixed bug found by Brad VanderZanden involving
;;;                   expanding a double-buffered window (caused by
;;;                   misprint in Configure-Notify).
;;; 25-Oct-90 Pervin  New exported commands opal:raise-window and
;;;                     opal:lower-window which move window to front or
;;;                     back of screen.
;;; 22-Oct-90 Pervin  Changed #+pmax to #+allegro since I found that
;;;		      xlib:query-tree no longer works on the Sun Allegro
;;;		      at CMU either.  This is a TEMPORARY change.  In time
;;;		      I hope whoever is responsible can get xlib:query-tree
;;;                   working.
;;; 10-Sep-90 Meltsner Fixed bug in initialize-window-border-widths of
;;;		      DECWindow users.     w5 --> p5
;;;  6-Sep-90 Pervin  Added an update-all at the end of Configure-Notify.
;;; 24-Aug-90 Pervin  You can now reset the :title and :icon-title
;;;		      of a window.
;;; 15-Aug-90 Pervin  Removed :display branch of case statement
;;;		      in fix-properties.
;;; 13-Aug-90 Pervin  Added code to handle DECWindows window manager.
;;; 10-Aug-90 Pervin  It turns out that I did need that event-case at
;;;		      the end of create-x-drawable after all (see 2-Aug-90).
;;;  9-Aug-90 Pervin  Added temporary #+pmax stuff because currently
;;;		      xlib:query-tree does not work on the Pmax.
;;;  3-Aug-90 Pervin  In Configure-Notify, check is window has parent.
;;;  2-Aug-90 Pervin  Reparent-notify must reset :lineage slot.
;;;		      Also, didn't need event-case at end of create-x-drawable.
;;;  1-Aug-90 Pervin  Made it so that the :width and :height slots of
;;;		      windows are based on the inside, rather than the
;;;		      outside of the window.
;;; 30-Jul-90 Pervin  Big changes in initialize-window-border-widths
;;;		      and Configure-Notify to handle MWM window manager.
;;;		      Got rid of :just-did-configure slot, but added
;;;		      new :lineage slot.
;;; 18-Jul-90 Pervin  Moved the call to initialize-window-border-widths
;;;		      yet again -- this time, to inside Configure-Notify.
;;;		      Also, expand-buffer uses :width, :height slots of
;;;		      window being expanded.
;;; 13-Jul-90 Pervin  New :destroy-me method for windows.
;;;		      I had to remove the optional erase argument.
;;;  5-Jul-90 Pervin  In Exposure, don't need special case for
;;;		      double-buffered window.
;;;  2-Jul-90 Pervin  If an expose event occurs, just refresh the parts
;;;                   of the window that were exposed.
;;; 26-Jun-90 Pervin  Extended :just-did-configure test to :width and
;;;                   :height slots, as well as :top and :left.
;;; 18-Jun-90 Pervin  Variable *clear* for erasing buffers.
;;;  5-Jun-90 Pervin  Implemented double-buffering.
;;;  4-Jun-90 Myers   Added :just-did-configure slot to windows
;;;		      in order to get rid of *twm-bug*
;;; 25-May-90 Pervin  Call initialize-window-border-widths only at the
;;;		      very end of create-x-drawable.
;;;  8-May-90 Sannella/Pervin
;;;                   The way of specifying a user-positioned window
;;;                   has changed.  Now we use the :user-specified-position-p
;;;                   argument to xlib:set-standard-properties.
;;; 19-Mar-90 Pervin  Changed :tile to :stipple.  Added reference to *twm-bug*
;;; 12-Mar-90 Pervin  Setting :title and :icon-title of windows
;;;		      in :initialize method.
;;; 28-Feb-90 Pervin  Fixed bug in set-window-cursor.
;;;		      Now it works in Lucid and Allegro too!
;;; 14-Feb-90 Pervin  Commented out body of set-window-cursor.
;;; 13-Feb-90 Pervin  Implemented color.
;;;  5-Dec-89 Pervin  Moved new-garnet-window-name to new-defs.lisp
;;;

(in-package "OPAL" :use '("LISP" "KR"))

;;; Windows

;;; Class Window 
;;; To create a window for displaying gobs, create a schema which is an
;;; instance of the window class described below specifying slots as
;;; needed. For example:
;;; 
;;; (create-instance my-window opal:window
;;;   (:width 100)
;;;   (:height 100))
;;; 

(define-method :point-in-gob opal::window (gob x y)
  (and (<= 0 x (g-value gob :width))
       (<= 0 y (g-value gob :height))))

;;; A couple routines useful for windows with backing store

;;; Create a buffer the same size as drawable.
(defun create-x-buffer (a-window)
  (let ((drawable (g-value a-window :drawable)))
    (xlib:create-pixmap :width (g-value a-window :width)
		        :height (g-value a-window :height)
		        :depth (xlib:drawable-depth drawable)
		        :drawable drawable)))

;;; Initalize the buffer to be background color.
(defun clear-buffer (buffer gc)
  (let ((background (xlib:gcontext-background gc)))
    (xlib:with-gcontext (gc :function opal::*copy*
			    :foreground background)
      (xlib:draw-rectangle buffer gc 0 0
	  (xlib:drawable-width buffer)
	  (xlib:drawable-height buffer) t))))

;;; Create new larger buffer.
(defun expand-buffer (a-window)
  (xlib:free-pixmap (g-value a-window :buffer))
  (s-value a-window :buffer (create-x-buffer a-window)))


;;; Map-notify is called when a :map-notify event occurs.
;;; It always sets the :visible slot of the window to T.
(defun Map-Notify (event-debug event-window)
  (when event-debug (format t "map-notify ~S~%" (xlib:window-id event-window)))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (if a-window
	(kr:with-demon-disabled  (g-value opal::window :invalidate-demon)
	  (s-value a-window :visible t))))
  t)

(defvar *exit-main-event-loop-function* NIL)

(defvar *inside-main-event-loop* nil)

;; returns t if any top level window is visible
(defun any-top-level-window-visible ()
  (dolist (win *garnet-windows*)
    (when (and (schema-p win)
	       (g-value win :visible)
	       (not (g-value win :parent)))
      (return-from any-top-level-window-visible t)))
  #|
  (maphash #'(lambda (xwin win)
		(declare (ignore xwin))
		(when (and (schema-p win)
			   (g-value win :visible)
			   (not (g-value win :parent)))
		  (return-from any-top-level-window-visible t)))
	    *drawable-to-window-mapping*)
  |#
  NIL)

;;; Unmap-notify is called when an :unmap-notify event occurs.
;;; It sets the :visible slot of the unmapped window as follows,
;;;           T  -->  :iconified      (invoked after the window is iconified
;;;                                    by hand)
;;;  :iconified  -->  :iconified      (invoked after opal:iconify-window)
;;;         NIL  -->  NIL             (invoked after the window is made
;;;                                    invisible)
;;; If no more window is visible and we are in a main-event-loop,
;;; then leave that event-loop.
(defun Unmap-Notify (event-debug event-window)
  (when event-debug (format t "unmap-notify ~S~%" (xlib:window-id event-window)))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (when (schema-p a-window)
      (if (g-value a-window :visible)
	  (with-demon-disabled (g-value opal::WINDOW :invalidate-demon)
	    (s-value a-window :visible :iconified)))
      (if (and *exit-main-event-loop-function*
	       (not (any-top-level-window-visible)))
	  (funcall *exit-main-event-loop-function*))))
  t)

(defun Circulate-Notify (event-debug)
  (when event-debug (format t "circulate-notify~%"))
  t)

(defun Gravity-Notify (event-debug)
  (when event-debug (format t "gravity-notify~%"))
  t)

;; Returns list of drawable, parent, grandparent, ... , root.
(defun lineage-of-drawable (drawable)
;;; Certain versions of Allegro CL/CLX give an error when you
;;; call xlib:query-tree.  These versions seem to be
;;; characterised by the feature :clx-cl-error.
#-clx-cl-error
  (multiple-value-bind (children parent root)
		       (xlib:query-tree drawable)
    (declare (ignore children))
    (if (eq parent root)
	(list drawable root)
	(cons drawable (lineage-of-drawable parent))))
#+clx-cl-error
  (list drawable opal::*default-x-root*)
)

(defun Reparent-Notify (event-debug event-window x y)
  (if event-debug (format t "reparent-notify ~s ~s ~s~%" event-window x y))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (if a-window
	(let ((drawable (g-value a-window :drawable)))
	  (when (and drawable (= (xlib:window-id drawable)
				 (xlib:window-id event-window)))
	    (s-value a-window :already-initialized-border-widths nil)
	    (s-value a-window :lineage (lineage-of-drawable event-window))))))
  t)

;;;       snarfed in it's entirety from hemlock code
;;; removes any events still drifting about on the queue that are meant for
;;; the window that is about to be destroyed
(defun deleting-window-drop-events (display win)
#-cmu (declare (ignore win))
  (xlib:display-finish-output display)
#+cmu  
  (let ((result nil))
    (xlib:process-event
     display :timeout 0
     :handler #'(lambda (&key event-window a-window &allow-other-keys)
		  (if (or (eq event-window win) (eq a-window win))
		      (setf result t)
		      nil)))
    result)
#-cmu
  (xlib:discard-current-event display)
  )

(defun Destroy-Notify (event-debug event-window)
  ;; do nothing, actually, probably destroy aggregate ?
  (when event-debug (format t " destroy-notify ~s~%" (xlib:window-id
						      event-window)))
  (deleting-window-drop-events (xlib:window-display event-window)
			       event-window)

  t)

(defun Delete-Notify (event-debug event-window)
  (if event-debug (format t " delete-notify ~s~%" (xlib:window-id
						   event-window)))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (if a-window
	(if (schema-p a-window)
	    (let ((drawable (g-value a-window :drawable)))
	      (if (and drawable (= (xlib:window-id drawable)
				   (xlib:window-id event-window)))
		  (destroy a-window)
		  ;; Then event-window is an orphaned window
		  (xlib:destroy-window event-window)))
	    ;; Then event-window is an orphaned window
	    (xlib:destroy-window event-window)))))

#+clx-mit-r4
(defun iconify-window (a-window)
  (let ((drawable (g-value a-window :drawable)))
    (when drawable
      (xlib:iconify-window drawable opal::*default-x-screen*))
    (s-value a-window :visible :iconified)
    (when drawable
      (xlib:display-force-output opal::*default-x-display*)))
)

#-clx-mit-r4
(defun iconify-window (a-window) (declare (ignore a-window)))

(defun deiconify-window (a-window)
  (s-value a-window :visible t)
  (update a-window))


(defun raise-window (a-window)
  (when (is-a-p a-window window)
    (let ((drawable (g-value a-window :drawable)))
      (when drawable
	(setf (xlib:window-priority drawable) :above))
      ;; if drawable was NIL, window will appear on top anyway.
      (update a-window)
      ;; if there were no invalid objects in the window, update wouldn't
      ;; have called display-force-output
      (xlib:display-force-output
       (display-info-display (g-value a-window :display-info))))))

(defun lower-window (a-window)
  (when (is-a-p a-window window)
    (let ((drawable (g-value a-window :drawable)))
      (unless drawable
	(setq drawable (create-x-drawable a-window)))
      (setf (xlib:window-priority drawable) :below)
      (update a-window)
      ;; if there were no invalid objects in the window, update wouldn't
      ;; have called display-force-output
      (xlib:display-force-output
       (display-info-display (g-value a-window :display-info))))))


#|
  Zoom operation:
	If :zoomdims are NIL, then
		store the window's dims in :zoomdims, and
		zoom the window
	else
		restore the window's dims to :zoomdims, and
		clear :zoomdims
|#
(defun zoom-window (a-window &optional fullzoom?)
  (when (is-a-p a-window window)
    (let ((zoomdims (g-local-value a-window :zoomdims)))
      (if zoomdims
	(progn
	  (s-value a-window :zoomdims NIL)
	  (s-value a-window :top    (aref zoomdims 0))
	  (s-value a-window :left   (aref zoomdims 1))
	  (s-value a-window :width  (aref zoomdims 2))
	  (s-value a-window :height (aref zoomdims 3)))

      ;else no zoomdims, so store zoomdims and zoom!
	(let ((top    (g-value a-window :top   ))
	      (left   (g-value a-window :left  ))
	      (width  (g-value a-window :width ))
	      (height (g-value a-window :height)))
	  (s-value a-window :zoomdims
		(make-array 4 :initial-contents (list top left width height)))
	  (s-value a-window :top 0)
	  (s-value a-window :height *screen-height*)
	  (when fullzoom?
	    (s-value a-window :left 0)
	    (s-value a-window :width *screen-width*))))
      (update a-window))))

(defun fullzoom-window (a-window) (zoom-window a-window T))

(defun convert-coordinates (win1 x y &optional win2)
  (let ((draw1 (when win1 (g-value win1 :drawable)))
	(draw2 (when win2 (g-value win2 :drawable))))
    #-clx-cl-error
    (when (and draw1 (null win2))
      (setq draw2 (xlib:drawable-root draw1)))
    #-clx-cl-error
    (when (and draw2 (null win1))
      (setq draw1 (xlib:drawable-root draw2)))
    (if (and draw1 draw2)
	(xlib:translate-coordinates draw1 x y draw2)
	(let ((left1 (if win1 (g-value win1 :left) 0))
	      (top1  (if win1 (g-value win1 :top) 0))
	      (left2 (if win2 (g-value win2 :left) 0))
	      (top2  (if win2 (g-value win2 :top) 0)))
	  (values (- (+ x left1) left2)
		  (- (+ y top1)  top2))))))


(defun simple-initialize-window-border-widths (a-window border-width)
  (s-value a-window :left-border-width border-width)
  (s-value a-window :top-border-width border-width)
  (s-value a-window :right-border-width border-width)
  (s-value a-window :bottom-border-width border-width))


(defun initialize-window-border-widths (a-window drawable)
  ;; find out what borders really are
  (if (g-value a-window :parent)  ;; window is really subwindow
      (simple-initialize-window-border-widths a-window 
				  (xlib:drawable-border-width drawable))
      (let ((lineage (g-value a-window :lineage)))
	(case (length lineage)
	  (2		;;; UWM or window without title
	   (simple-initialize-window-border-widths a-window
				  (xlib:drawable-border-width drawable)))
	  (3		;;; TWM
	   (let ((border-width (xlib:drawable-border-width (second lineage))))
	       (s-value a-window :left-border-width
			(+ border-width (xlib:drawable-x drawable)))
	       (s-value a-window :top-border-width
			(+ border-width (xlib:drawable-y drawable)))
	       (s-value a-window :right-border-width
			(- (xlib:drawable-width (second lineage))
			   (xlib:drawable-width (first lineage))
			   (xlib:drawable-x (first lineage))
			   (- border-width)))
	       (s-value a-window :bottom-border-width
			(- (xlib:drawable-height (second lineage))
			   (xlib:drawable-height (first lineage))
			   (xlib:drawable-y (first lineage))
			   (- border-width)))))
	  ((4 6)	;;; MWM and DECWindows, or possibly TVTWM
	   ;; if it is TVTWM, i.e. 3rd window is virtual root
	   (if (xlib:get-property (third lineage) :__SWM_VROOT)
	       (let* ((parent (second lineage))
		      (border-width (xlib:drawable-border-width parent)))
		 (s-value a-window :left-border-width
			  (+ border-width (xlib:drawable-x (first lineage))))
		 (s-value a-window :top-border-width
			  (+ border-width (xlib:drawable-y (first lineage))))
		 (s-value a-window :right-border-width
			  (- (xlib:drawable-width (second lineage))
			     (xlib:drawable-width (first lineage))
			     (xlib:drawable-x (first lineage))
			     (- border-width)))
		 (s-value a-window :bottom-border-width
			  (- (xlib:drawable-height (second lineage))
			     (xlib:drawable-height (first lineage))
			     (xlib:drawable-y (first lineage))
			     (- border-width))))
	       (let* ((parent (second lineage))
		      (grandparent (third lineage))
		      (left-border-width
		       (MAX (xlib:drawable-x parent)  ; MWM
			    (xlib:drawable-border-width parent))) ; DECwindows
		      (top-border-width (xlib:drawable-y parent)))
		 (s-value a-window :left-border-width left-border-width)
		 (s-value a-window :top-border-width top-border-width)
		 (s-value a-window :right-border-width
		   (- (xlib:drawable-width grandparent)
		      (xlib:drawable-width parent)
		      left-border-width))
		 (s-value a-window :bottom-border-width
		   (- (xlib:drawable-height grandparent)
		      (xlib:drawable-height parent)
		      top-border-width)))))))))
;	  (6            ;;; DECWindows
;	   (let* ((p4 (fourth lineage))
;		  (p5 (fifth lineage))
;		  (w4 (xlib:drawable-border-width p4))
;		  (w5 (xlib:drawable-border-width p5)))
;	     (s-value a-window :left-border-width (+ w4 w5))
;	     (s-value a-window :top-border-width (+ w4 (xlib:drawable-x p5)))
;	     (s-value a-window :right-border-width (+ w4 w5))
;	     (s-value a-window :bottom-border-width (+ w4 w5))))))))

(defun Configure-Notify (event-debug x y width height event-window
			 above-sibling)
  (if event-debug
      (format t "Configure-notify win=~s ~s ~s ~s ~s ~s~%"
	      (xlib:window-id event-window) x y
	      width height (if above-sibling
			       (xlib:window-id above-sibling))))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (if a-window
	(let ((drawable (g-value a-window :drawable)))
	  (when (and drawable
		     (= (xlib:window-id drawable)
			(xlib:window-id event-window))
 ;; szekely: added test for window being visible.  This eliminates the
 ;; problem of the configure notify that olwm sends before mapping a window.
		     (g-value a-window :visible))
      (if (g-value a-window :parent)
	  (progn			; If it's a subwindow, we don't
	    (s-value a-window :left x)  ; have to check lineage.
	    (s-value a-window :top y))
	  (unless (eq (g-value a-window :visible) :iconified)
	   (let ((lineage (or (g-value a-window :lineage)
			      (s-value a-window :lineage
				      (lineage-of-drawable event-window)))))
	    (case (length lineage)
	      #-clx-cl-error
	      (2	;;; UWM or window without label.
	       (s-value a-window :left x)
	       (s-value a-window :top y))
	      #+clx-cl-error
	      (2	;;; xlib:query-tree does not work, so true
			;;; values of left and top may be unobtainable.
			;;; In fact, x and y will be 0 if you have just
			;;; resized the window.
	       (unless (and (zerop x) (zerop y))
	         (s-value a-window :left x)
	         (s-value a-window :top y)))
	      (3	;;; TWM
	       (s-value a-window :left (xlib:drawable-x (second lineage)))
	       (s-value a-window :top (xlib:drawable-y (second lineage))))
	      ((4 6)	;;; MWM and DECWindows, or possibly TVTWM
	       (let ((3rd (third lineage)))
		 (if (xlib:get-property 3rd :__SWM_VROOT)
		     (let ((2nd (second lineage)))
		       (s-value a-window :left (xlib:drawable-x 2nd))
		       (s-value a-window :top (xlib:drawable-y 2nd)))
		     (progn
		       (s-value a-window :left (xlib:drawable-x 3rd))
		       (s-value a-window :top (xlib:drawable-y 3rd))))))))))
      (unless (or (g-value a-window :already-initialized-border-widths)
		  (eq (g-value a-window :visible) :iconified))
	(initialize-window-border-widths a-window event-window)
	(s-value a-window :already-initialized-border-widths t))
      (s-value a-window :width width)
      (s-value a-window :height height)
      ;; Don't want top, left, width, height to be invalid,
      ;; or else we might get a drifting window.
      (let ((win-info (g-value a-window :win-update-info)))
	(setf (win-update-info-invalid-slots win-info)
	      (set-difference (win-update-info-invalid-slots win-info)
			      '(:left :top :width :height))))
      (let ((old-buffer (g-value a-window :buffer)))
	(when (and old-buffer
		   (or (> height (xlib:drawable-height old-buffer))
		       (> width  (xlib:drawable-width old-buffer))))
	  (expand-buffer a-window)
	  ;; This update will redraw contents of window into new buffer.
	  (update a-window t)))
      (opal:update-all)
      ))))
  t)

(defun Exposure (event-debug event-window count x y width height display)
  (declare (ignore display))
  (when event-debug
    (format t "exposure, count = ~S window-id=~s"
	    count (xlib:window-id event-window)))
  (let ((a-window (getf (xlib:drawable-plist event-window) :garnet)))
    (if (schema-p a-window)
	(let ((drawable (g-value a-window :drawable)))
	  (if (and drawable
		   (= (xlib:window-id drawable)
		      (xlib:window-id event-window)))
	      ;; Do not update the window in the case where the window
	      ;; was just created and mapped for the first time.
	      (if (g-local-value a-window :very-first-exposure)
		  (when (zerop count)
		    (kr:destroy-slot a-window :very-first-exposure))
		  (let* ((win-ui
			   (get-local-value a-window :win-update-info))
			 (exposed-bbox (win-update-info-exposed-bbox win-ui)))
		    (unless exposed-bbox
		      (setq exposed-bbox
		        (setf (win-update-info-exposed-bbox win-ui)
		          (opal::make-bbox :valid-p NIL))))
		    (if (bbox-valid-p exposed-bbox)
		      ;; already valid, so merge into existing bbox
		      (setf (bbox-x2 exposed-bbox)
		                     (max (+ x width)
		                          (bbox-x2 exposed-bbox))
		            (bbox-y2 exposed-bbox)
		                     (max (+ y height)
		                          (bbox-y2 exposed-bbox))
		            (bbox-x1 exposed-bbox)
		                     (min x (bbox-x1 exposed-bbox))
		            (bbox-y1 exposed-bbox)
		                     (min y (bbox-y1 exposed-bbox)))
		      ;; invalid, so copy in and make valid
		      (setf (bbox-valid-p exposed-bbox) T
		            (bbox-x2 exposed-bbox) (+ x width)
		            (bbox-y2 exposed-bbox) (+ y height)
		            (bbox-x1 exposed-bbox) x
		            (bbox-y1 exposed-bbox) y))
		    (when (zerop count)
		      (s-value a-window :exposed-bbox exposed-bbox)
		      (kr-send a-window :update a-window t)
		      (s-value a-window :exposed-bbox nil)
		      (setf (bbox-valid-p exposed-bbox) NIL))))))))
  t)

;; We will now only define a single
;; default-event-handler in inter/i-windows.lisp
#|
(defun default-event-handler (display)
  "Event handler for the interactor windows"
  ;; yes indeed, every clause should return T, not NIL!
  (xlib:event-case (display :discard-p t)
    (:MAP-NOTIFY (event-window) (Map-notify *event-debug* event-window))
    (:UNMAP-NOTIFY (event-window) (Unmap-notify *event-debug* event-window))
    (:CIRCULATE-NOTIFY () (Circulate-notify *event-debug*))
    (:REPARENT-NOTIFY (event-window x y)
			 (Reparent-Notify *event-debug* event-window x y)) 
    (:GRAVITY-NOTIFY () (Gravity-notify *event-debug*))
    (:DESTROY-NOTIFY (event-window) (Destroy-notify *event-debug* event-window))
    (:CONFIGURE-NOTIFY (x y width height event-window above-sibling)
		       (Configure-Notify *event-debug* x y width height
					 event-window above-sibling))
    (:EXPOSURE (event-window count x y width height)
	       (Exposure *event-debug* event-window count x y width height display))
    (:NO-EXPOSURE () t)
    (OTHERWISE () (format t "illegal event") t)))
|#

(defun display-info-printer (s stream ignore)
  (declare (ignore ignore))
  (format stream "#<OPAL-DISPLAY-INFO ~A>" (display-info-display s)))

(defun initialize-display ()
  (let* ((x-line-style-gc
	      (xlib:create-gcontext :drawable *default-x-root*
				    :cache-p t
				    :function 2
				    :foreground opal::*black*
				    :background opal::*white*
				    :line-width 0
				    :line-style :solid
				    :cap-style :butt
				    :join-style :miter
				    :fill-style :solid
				    :fill-rule :even-odd))
	 (x-filling-style-gc
	      (xlib:create-gcontext :drawable *default-x-root*
				    :cache-p t
				    :function 2
				    :foreground opal::*black*
				    :background opal::*white*
				    :line-width 0
				    :line-style :solid
				    :cap-style :butt
				    :join-style :miter
				    :fill-style :solid
				    :fill-rule :even-odd))
	 (opal-line-style-gc
		(make-opal-gc	:gcontext x-line-style-gc
				:opal-style NIL
				:function 2
				:line-width 0
				:line-style :solid
				:cap-style  :butt
				:join-style :miter
				:dashes NIL
				:font   NIL
				:fill-style :solid
				:fill-rule  :even-odd
				:stipple   NIL
				:clip-mask :none
				:stored-clip-mask (make-list 8)))
	 (opal-filling-style-gc
		(make-opal-gc	:gcontext x-filling-style-gc
				:opal-style NIL
				:function 2
				:line-width 0
				:line-style :solid
				:cap-style  :butt
				:join-style :miter
				:dashes NIL
				:font   NIL
				:fill-style :solid
				:fill-rule  :even-odd
				:stipple   NIL
				:clip-mask :none
				:stored-clip-mask (make-list 8))))

   (make-display-info :display *default-x-display*
		      :screen  *default-x-screen*
		      :root-window *default-x-root*
		      :line-style-gc opal-line-style-gc
	 	      :filling-style-gc opal-filling-style-gc)))


;; The PAIR argument can either be
;; 1) A dotted pair of two bitmaps: an image and a mask
;; 2) A three-element list consisting of a font and two indices into the font
;;    indicating a cursor character and its mask
;; 3) Same as #2 only with :CURSOR as the first element instead of a font.
;;    In this case, opal:CURSOR-FONT is used as the font.
;;
(defun set-window-cursor (a-window drawable pair)

  ;; First, look up the bitmap pair in the association list of known cursors
  (let ((old-cursor (cdr (assoc pair (g-value a-window :cursor-pairs)
				:test #'equal))))
    (if old-cursor
	(setf (xlib:window-cursor drawable) old-cursor)

	;; Haven't seen this bitmap pair before in this window.  Create
	;; a new cursor pixmap, which will be used to create a new cursor.
	(let ((pair-car (car pair))
	      (new-cursor NIL))
	  (cond
	    ((is-a-p pair-car opal:bitmap)
	     (let* ((display-info (g-value a-window :display-info))
		    (root-window (display-info-root-window display-info))
		    (screen (display-info-screen display-info))
		    (cursor-bm (g-value pair-car :image))
		    (cursor-width (xlib:image-width cursor-bm))
		    (cursor-height (xlib:image-height cursor-bm))
		    (cursor-pm (xlib:create-pixmap :width cursor-width
						   :height cursor-height
						   :depth 1
						   :drawable root-window))
		    (mask-bm (g-value (cdr pair) :image))
		    (gc nil) (mask-pm nil) (mask-width nil) (mask-height nil))
	       ;; Write the mask into the cursor pixmap
	       (when mask-bm
		 (setf mask-pm (xlib:create-pixmap
				:width (setf mask-width
					     (xlib:image-width mask-bm))
				:height (setf mask-height
					      (xlib:image-height mask-bm))
				:depth 1
				:drawable root-window))
		 (setf gc (xlib:create-gcontext
			   :drawable mask-pm :function boole-1
			   :foreground (xlib:screen-white-pixel screen)
			   :background (xlib:screen-black-pixel screen)))
		 (xlib:put-image mask-pm gc mask-bm :x 0 :y 0
				 :width mask-width :height mask-height)
		 (xlib:free-gcontext gc))

	       ;; Write the bitmap into the cursor pixmap
	       (setf gc (xlib:create-gcontext
			 :drawable cursor-pm :function boole-1
			 :foreground (xlib:screen-white-pixel screen)
			 :background (xlib:screen-black-pixel screen)))
	       (xlib:put-image cursor-pm gc cursor-bm :x 0 :y 0
			       :width cursor-width :height cursor-height)
	       (xlib:free-gcontext gc)

	       ;; Create a new cursor with the cursor pixmap
	       (setf new-cursor
		     (xlib:create-cursor
		      :source cursor-pm :mask (if mask-bm mask-pm)
		      :x (or (xlib:image-x-hot cursor-bm) 0)
		      :y (or (xlib:image-y-hot cursor-bm) 0)
		      :foreground (g-value opal:black :xcolor)
		      :background (g-value opal:white :xcolor)))
	       (setf (xlib:window-cursor drawable) new-cursor)
	       (xlib:free-pixmap cursor-pm)
	       (if mask-bm (xlib:free-pixmap mask-pm))))

	    ((or (eq pair-car :CURSOR)
		 (is-a-p pair-car opal:font-from-file))
	     (let* ((xfont (if (eq pair-car :CURSOR)
			       (g-value opal::CURSOR-FONT :xfont)
			       (g-value pair-car :xfont)))
		    (cursor-char (second pair))
		    (mask-char (third pair)))
	       (setf new-cursor
		     (xlib:create-glyph-cursor
		      :source-font xfont  :source-char cursor-char
		      :mask-font xfont    :mask-char mask-char
		      :foreground (g-value opal:black :xcolor)
		      :background (g-value opal:white :xcolor)))
	       (setf (xlib:window-cursor drawable) new-cursor)))
	    (t (error "Can't parse cursor spec ~S.~%" pair)))

	  ;; Store the cursor in case we see this pair again
	  (push (cons pair new-cursor) (g-value a-window :cursor-pairs))
	)))
  t)


(defun Change-Cursors (pair &optional a-window-list)
  (let ((window-list (or a-window-list *garnet-windows*))
	(display NIL))
    (dolist (a-window window-list)
      ;; Don't change the cursor of windows that don't have drawables yet.
      ;; Identify these beasties via their :display-info slot.
      (let ((display-info (g-value a-window :display-info)))
	(when display-info
	  (Set-Window-Cursor a-window (g-value a-window :drawable) pair)
	  (or display (setf display (display-info-display display-info))))))
    (if display
	(xlib:display-force-output display))))

(defun Restore-Cursors (&optional a-window-list)
  (let ((window-list (or a-window-list *garnet-windows*))
	(display NIL))
    (dolist (a-window window-list)
      (let ((display-info (g-value a-window :display-info)))
	(when display-info
	  (Set-Window-Cursor a-window
			     (g-value a-window :drawable)
			     (g-value a-window :cursor))
	  (or display (setf display (display-info-display display-info))))))
    (if display
	(xlib:display-force-output display))))

(defmacro With-Cursor (cursor &body body)
  `(unwind-protect (progn
		     (opal:change-cursors ,cursor)
		     ,@body)
    (opal:restore-cursors)))

(defmacro With-HourGlass-Cursor (&body body)
  `(unwind-protect (progn
		     (opal:change-cursors opal:HourGlass-Pair)
		     ,@body)
    (opal:restore-cursors)))
  

;;; Set the :window slot of the window to be the window itself!
(define-method :initialize opal::window (a-window)
  (call-prototype-method a-window)
  (let ((win-info (make-win-update-info))
	(a-window-update-info (g-local-value a-window :update-info)))
    (unless (g-local-value a-window :title)
      (s-value a-window :title (new-garnet-window-name)))
    (unless (g-local-value a-window :icon-title)
      (s-value a-window :icon-title (g-value a-window :title)))
    (s-value a-window :win-update-info win-info)
    (if a-window-update-info
	(s-value a-window :window
		 (setf (update-info-window a-window-update-info) a-window)))
    (pushnew a-window *garnet-windows*)
    (let ((parent (g-value a-window :parent)))
      (when parent
	;; dzg - 11-27-1991
 	(s-value parent :child (cons a-window (g-local-value parent :child)))))
    (setf (win-update-info-new-bbox win-info) (make-bbox))
    ;;; Clip-mask-1 is the last four elements of clip-mask-2.
    (setf (win-update-info-clip-mask-1 win-info)
      (cddddr
        (setf (win-update-info-clip-mask-2 win-info) (make-list 8))))))


;;; Sets the icon of a window to be a particular pixmap.
(defun set-wm-icon (drawable bitmap-file)
  (when bitmap-file
    (if (stringp bitmap-file)
	(if (probe-file bitmap-file)
            (let* ((image (opal:read-image bitmap-file))
                   (width (xlib:image-width image))
                   (height (xlib:image-height image))
                   (pixmap (opal::build-pixmap drawable image width height t)))
               (xlib:set-standard-properties drawable :icon-pixmap pixmap))
	    (format t "Warning: Icon bitmap file ~A does not exist." bitmap-file))
	(warn "Warning: the :icon-bitmap slot of a window should be NIL or a string."))))

;;; Sets the gcontext-subwindow-mode of the gcontexts of a window's display.
(defun set-subwindow-mode (display-info mode)
  (setf (xlib:gcontext-subwindow-mode
          (opal-gc-gcontext
	    (display-info-line-style-gc display-info)))
	mode)
  (setf (xlib:gcontext-subwindow-mode
	  (opal-gc-gcontext
	    (display-info-filling-style-gc display-info)))
        mode))


;;; Does a map-window, and then waits for it to actually appear
;;; on the screen.  The waiting is necessary, because otherwise
;;; objects in the window won't appear in Lucid and Allegro
;;; (due to some race condition).
#+(or lucid allegro lispworks)
(defun map-window-and-wait (drawable display)
 (when (eq (xlib:window-map-state drawable) :unmapped)
  (let ((suspend-process (main-event-loop-process-running-p)))
     (when suspend-process
	(kill-main-event-loop-process))
     (xlib:map-window drawable)
     (xlib:display-force-output display)
     (xlib:event-case (display :discard-p nil :peek-p t :timeout 5)
        (:map-notify (event-window) (eq event-window drawable)))
     (when suspend-process
	(launch-main-event-loop-process)))))

#-(or lucid allegro lispworks)
(defun map-window-and-wait (drawable display)
  (xlib:map-window drawable)
  (xlib:display-force-output display))
  

;;;; This now returns the drawable it creates.
(defun create-x-drawable (a-window)
  (let* ((display-info (initialize-display))
	 (title-name (g-value a-window :title))
	 (left (g-value a-window :left))
	 (top  (g-value a-window :top))
	 (border-width (g-value a-window :border-width))
	 (width  (g-value a-window :width))
	 (height (g-value a-window :height))
	 (parent (get-parent-win a-window display-info))
	 (screen (display-info-screen display-info))
	 (white-pixel (xlib:screen-white-pixel screen))
	 (black-pixel (xlib:screen-black-pixel screen))
	 (background (if (g-value color :color-p)
		         (if (g-value a-window :background-color)
			     (g-value a-window :background-color :colormap-index)
			     white-pixel)
			 (if (eq (g-value a-window :background-color) black)
			     black-pixel
			     white-pixel)))
	 (drawable (xlib:create-window
		    :parent parent
		    :x left
		    :y top
		    :width width
		    :height height
		    :background background
		    :border-width border-width
		    :border black-pixel
	       	    :override-redirect (if (g-value a-window :omit-title-bar-p)
					   :on :off)
		    :event-mask *exposure-event-mask*
		    :save-under (if (g-value a-window :save-under) :on :off)
		    :class :input-output)))
    (setf (xlib:wm-hints drawable)
          (xlib:make-wm-hints :input :on
                              :initial-state
                                 (if (eq (g-value a-window :visible) :iconified)
                                     :iconic
                                     :normal)))
    (setf (xlib:wm-normal-hints drawable)
       (xlib:make-wm-size-hints :width-inc 1
				:height-inc 1
			        :x left
		    	        :y top
				:min-width (g-value a-window :min-width)
				:min-height (g-value a-window :min-height)
				:max-width (g-value a-window :max-width)
				:max-height (g-value a-window :max-height)
				:user-specified-position-p
				  (not (g-value a-window :position-by-hand))
				:user-specified-size-p
				  (not (g-value a-window :position-by-hand))))
    (xlib:set-standard-properties drawable
				:name title-name
				:icon-name (or (g-value a-window :icon-title)
						  title-name))

    (set-wm-icon drawable (g-value a-window :icon-bitmap))

    ;;; The following allows you to destroy windows by hand using the
    ;;; window manager.  Unfortunately, this does not work in lispworks, but
    ;;; causes an error with mysterious message "#\U is not of type integer".
    ;;;
    ;;; The same error appeared in clisp before the addition of
    ;;; :TRANSFORM #'xlib:char->card8. I guess it is related to missing error
    ;;; error checking in other implementations than clisp and lispworks.
    ;;; B. Haible 20.9.1993
#-lispworks
    (xlib:change-property drawable
			  :WM_CLIENT_MACHINE #-clisp (short-site-name)
			                     #+clisp ""
			  :STRING 8
			  #+clisp :TRANSFORM #+clisp #'xlib:char->card8)

    (xlib:change-property drawable :WM_PROTOCOLS
				(list (xlib:intern-atom
					 (display-info-display display-info)
					 "WM_DELETE_WINDOW"))
				:ATOM 32)

    (when (g-value a-window :draw-on-children)
      (set-subwindow-mode display-info :include-inferiors))

    (setf (g-value a-window :drawable) drawable)
    (setf (g-value a-window :display-info) display-info)
    (setf (getf (xlib:drawable-plist drawable) :garnet) a-window)
    (when (g-value a-window :double-buffered-p)
      (let* ((buffer (create-x-buffer a-window))
	     (buffer-gc (xlib:create-gcontext :drawable buffer
				:foreground black-pixel
				:background background)))
        (s-value a-window :buffer buffer)
        (s-value a-window :buffer-gcontext buffer-gc)
	(clear-buffer buffer buffer-gc)))

    (s-value a-window :top-border-width border-width)
    (s-value a-window :left-border-width border-width)
    (s-value a-window :bottom-border-width border-width)
    (s-value a-window :right-border-width border-width)

    (s-value a-window :very-first-exposure t)

    ;; set the cursor to hemlock's cursor or specified cursor/mask combo
    ;; (cursor-file . mask-file)
    (set-window-cursor a-window
		       drawable
		       (g-value a-window :cursor))

    ;; bring up the window, and display it
    (when (g-value a-window :visible)
      (map-window-and-wait drawable (display-info-display display-info))
    )

    (s-value a-window :old-parent (g-value a-window :parent))
    drawable))



(defun fix-window-properties (a-window changed-slots drawable)
  (let (make-new-buffer map-window-at-end-of-fix-properties)
    (xlib:with-state (drawable)
      (dolist (slot changed-slots)
	(case slot
	  ((:aggregate :drawable)
	   (let* ((win-info (g-value a-window :win-update-info))
		  (old-agg  (win-update-info-old-aggregate win-info))
		  (agg      (g-value a-window :aggregate)))
	     (set-window-cursor a-window
				drawable
				(g-value a-window :cursor))
	     (unless (eq old-agg agg)
	       (if (and (kr:schema-p old-agg)
		        (eq (g-value old-agg :window)
			    a-window))
		   (set-display-slots old-agg NIL NIL))
	       (if agg
		   (set-display-slots agg a-window T))
	       (setf (win-update-info-old-aggregate win-info) agg)
	       (if (and old-agg (null agg))
		   (xlib:clear-area drawable)))))
	  (:parent
	   (let ((old-parent (g-value a-window :old-parent))
	         (new-parent (g-value a-window :parent))
		 (left       (g-value a-window :left))
		 (top        (g-value a-window :top)))
	    (unless (eq old-parent new-parent)
	      ;; first, fix old-parent's :child slot
	      (if (schema-p old-parent)
	          (s-value old-parent :child
	                   (delete a-window (g-value old-parent :child))))

	      ;; then update new-parent's :child slot
	      (if (schema-p new-parent)
	          (s-value new-parent :child
	                   (pushnew a-window (g-value new-parent :child))))

	      ;; then update slots of the window itself
	      (s-value a-window :lineage nil)
	      (s-value a-window :old-parent new-parent)

	      ;; and, finally, tell X to reparent the drawable
	      (if new-parent
		  ;; Attach a-window to new-parent
		  (cond
		   ((is-a-p new-parent opal::window)
		    ;; You can only reparent windows that don't have title
		    ;; bars, so if the window has one, we have to destroy the
		    ;; drawable and create a new one already parented.
		    ;; You would think that you do not have to reparent the
		    ;; new drawable, but the new drawable is not clipped into
		    ;; the new parent unless you call xlib:reparent-window
		    (unless (eq (xlib:window-override-redirect drawable) :on)
		      (xlib:unmap-window drawable)
		      (setf (getf (xlib:drawable-plist drawable) :garnet) NIL)
		      (xlib:destroy-window drawable)
		      (setf drawable (create-x-drawable a-window)))
		    (xlib:reparent-window drawable
					  (g-value new-parent :drawable)
					  left top))
		   (t (error "Parent ~S of window ~S is not of type window~%"
			     new-parent a-window)))
		  
		  ;; New-parent is NIL, so attach a-window to the root window.
		  (progn
		    (xlib:reparent-window drawable
					  (display-info-root-window
					   (g-value a-window :display-info))
					  left top))))))

	  (:cursor
	   (set-window-cursor a-window
			      drawable
			      (g-value a-window :cursor)))
	  (:title
	   (setf (xlib:wm-name drawable)
		 (g-value a-window :title))
	   (xlib:set-standard-properties drawable
				   :name (g-value a-window :title)))
	  (:icon-title
	   (xlib:set-standard-properties drawable
				   :icon-name (g-value a-window :icon-title)))
	  (:top
	   (let ((hints (xlib:wm-normal-hints drawable))
		 (new-y (+ (g-value a-window :top)
			   (g-value a-window :top-border-width))))
	     (setf (xlib:drawable-y drawable) new-y
		   (xlib:wm-size-hints-y hints) new-y
		   (xlib:wm-normal-hints drawable) hints)))
	  (:left
	   (let ((hints (xlib:wm-normal-hints drawable))
		 (new-x (+ (g-value a-window :left)
			   (g-value a-window :left-border-width))))
	     (setf (xlib:drawable-x drawable) new-x
		   (xlib:wm-size-hints-x hints) new-x
		   (xlib:wm-normal-hints drawable) hints)))
	  (:width
	   (let ((width (g-value a-window :width))
		 (old-buffer (g-value a-window :buffer)))
	     (setf (xlib:drawable-width drawable)
		   (max 0 width))
	     (setf (win-update-info-width (g-value a-window :win-update-info))
		   width)
	     (when (and old-buffer
		        (> width (xlib:drawable-width old-buffer)))
		(setq make-new-buffer t))))
	  (:height
	   (let ((height (g-value a-window :height))
                 (old-buffer (g-value a-window :buffer)))
	     (setf (xlib:drawable-height drawable)
		   (max 0 height))
	     (setf (win-update-info-height (g-value a-window :win-update-info))
		   height)
	     (when (and old-buffer
		        (> height (xlib:drawable-height old-buffer)))
                (setq make-new-buffer t))))
	  (:background-color
	   (let* ((bc (g-value a-window :background-color))
		  (gc (g-value a-window :buffer-gcontext))
		  (index (if (g-value color :color-p)
			     (if bc (g-value bc :colormap-index) *white*)
			     (if (eq bc black) *black* *white*))))
	     (setf (xlib:window-background drawable) index)
	     (when gc (setf (xlib:gcontext-background gc) index)))
	   (when (g-value a-window :visible)
	     (xlib:map-window drawable)))
	  (:icon-bitmap
	   (set-wm-icon drawable (g-value a-window :icon-bitmap)))
	  (:draw-on-children
	   (let ((display-info (g-value a-window :display-info)))
	     (if (g-value a-window :draw-on-children)
	         (set-subwindow-mode display-info :include-inferiors)
	         (set-subwindow-mode display-info :clip-by-children))))
	  (:save-under
	   (setf (xlib:window-save-under drawable)
	     (if (g-value a-window :save-under) :on :off)))
	  (:visible
	   (let ((vis (g-value a-window :visible)))
	     (cond ((eq vis t)
		    (setq map-window-at-end-of-fix-properties t))
		   ((eq vis :iconified)
		    #+clx-mit-r4
		    (xlib:iconify-window drawable *default-x-screen*))
		   ((eq vis nil)
		    #+clx-mit-r4
		    (xlib:withdraw-window drawable *default-x-screen*)
		    #-clx-mit-r4
	            (xlib:unmap-window drawable)))))
          )))
    ; Do this last so that window does not momentarily flicker
    ; in its old position
    (when map-window-at-end-of-fix-properties
       (map-window-and-wait drawable
		   (display-info-display (g-value a-window :display-info)))
    )
    ; Expand buffer after the with-state, but within let.
    (when make-new-buffer
      (expand-buffer a-window)))
)


(define-method :destroy-me opal::window (a-window)
  ;; first recursively destroy all subwindows
  (dolist (child (g-value a-window :child))
    (when (eq a-window (g-value child :parent))
      (destroy child)))
  ;; remove window from parent (if not top-level)
  (let ((parent (g-value a-window :parent)))
    (if parent
	(s-value parent :child
		 (delete a-window (g-local-value parent :child)))))
  ;; then destroy main window
  (let ((drawable (g-value a-window :drawable)))
    (when drawable
      (setf *garnet-windows* (delete a-window *garnet-windows*))
      (setf (getf (xlib:drawable-plist drawable) :garnet) NIL)
      (xlib:destroy-window drawable)
      (xlib:display-force-output
       (display-info-display (g-value a-window :display-info)))))
  (let ((agg (g-value a-window :aggregate)))
    (when agg (destroy agg nil)))
  (s-value a-window :window nil)
  ;; destroy the backing store
  (let ((buffer (g-value a-window :buffer)))
    (when buffer
      (xlib:free-pixmap buffer)
      (xlib:free-gcontext (g-value a-window :buffer-gcontext))))
  (call-prototype-method a-window))

(define-method :destroy opal::window (a-window)
  (dolist (instance (copy-list (g-local-value a-window :is-a-inv)))
    (destroy instance))
  (destroy-me a-window)
  (when (and *exit-main-event-loop-function*
	     (not (any-top-level-window-visible)))
    (funcall *exit-main-event-loop-function*)))

(define-method :flush opal::window (a-window)
  (xlib:display-force-output
   (display-info-display (g-value a-window :display-info))))

;;; The following two functions have been added to be used by interactors.
;;; They are exported from Opal.
(defun Get-X-Cut-Buffer (window)
    (if window
      (xlib:cut-buffer
       (opal::display-info-display (g-value window :display-info)))
      ; else return the empty string
      ""))

(defun Set-X-Cut-Buffer (window newstring)
    (when window
      (setf (xlib:cut-buffer
             (opal::display-info-display (g-value window :display-info)))
            newstring)))
